X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fassembly%2Fx86-64%2Farith.lisp;h=6a1fe24ddb96f9070730c8e3d3b096a0059432d4;hb=37b1ed8e9b6faa84832b8251998b5d0eb1f6b307;hp=a6f4d5e0389acf6c3573750524faa11bf7630f48;hpb=3da8e4ca35e534942f7a5046490d169509170c85;p=sbcl.git diff --git a/src/assembly/x86-64/arith.lisp b/src/assembly/x86-64/arith.lisp index a6f4d5e..6a1fe24 100644 --- a/src/assembly/x86-64/arith.lisp +++ b/src/assembly/x86-64/arith.lisp @@ -14,54 +14,53 @@ ;;;; addition, subtraction, and multiplication (macrolet ((define-generic-arith-routine ((fun cost) &body body) - `(define-assembly-routine (,(symbolicate "GENERIC-" fun) - (:cost ,cost) - (:return-style :full-call) - (:translate ,fun) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) rdx-offset) - (:arg y (descriptor-reg any-reg) - ;; this seems wrong esi-offset -- FIXME: What's it mean? - rdi-offset) - - (:res res (descriptor-reg any-reg) rdx-offset) - - (:temp rax unsigned-reg rax-offset) - (:temp rbx unsigned-reg rbx-offset) - (:temp rcx unsigned-reg rcx-offset)) - - (declare (ignorable rbx)) - - (inst test x 7) ; fixnum? - (inst jmp :nz DO-STATIC-FUN) ; no - do generic - (inst test y 7) ; fixnum? - (inst jmp :z DO-BODY) ; yes - doit here - - DO-STATIC-FUN - (inst pop rax) - (inst push rbp-tn) - (inst lea - rbp-tn - (make-ea :qword :base rsp-tn :disp n-word-bytes)) - (inst sub rsp-tn (fixnumize 2)) - (inst push rax) ; callers return addr - (inst mov rcx (fixnumize 2)) ; arg count - (inst jmp - (make-ea :qword - :disp (+ nil-value - (static-fun-offset - ',(symbolicate "TWO-ARG-" fun))))) - - DO-BODY - ,@body))) - + `(define-assembly-routine (,(symbolicate "GENERIC-" fun) + (:cost ,cost) + (:return-style :full-call) + (:translate ,fun) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) rdx-offset) + (:arg y (descriptor-reg any-reg) rdi-offset) + + (:res res (descriptor-reg any-reg) rdx-offset) + + (:temp rax unsigned-reg rax-offset) + (:temp rcx unsigned-reg rcx-offset)) + + (inst mov rcx x) + (inst or rcx y) + (inst test rcx fixnum-tag-mask) ; both fixnums? + (inst jmp :nz DO-STATIC-FUN) ; no - do generic + + ,@body + (inst clc) ; single-value return + (inst ret) + + DO-STATIC-FUN + ;; Same as: (inst enter (* n-word-bytes 1)) + (inst push rbp-tn) + (inst mov rbp-tn rsp-tn) + (inst sub rsp-tn (* n-word-bytes 1)) + (inst push (make-ea :qword :base rbp-tn + :disp (frame-byte-offset return-pc-save-offset))) + (inst mov rcx (fixnumize 2)) ; arg count + (inst jmp + (make-ea :qword + :disp (+ nil-value + (static-fun-offset + ',(symbolicate "TWO-ARG-" fun)))))))) + + #.` (define-generic-arith-routine (+ 10) (move res x) (inst add res y) (inst jmp :no OKAY) - (inst rcr res 1) ; carry has correct sign - (inst sar res 2) ; remove type bits + ;; Unbox the overflowed result, recovering the correct sign from + ;; the carry flag, then re-box as a bignum. + (inst rcr res 1) + ,@(when (> n-fixnum-tag-bits 1) ; don't shift by 0 + '((inst sar res (1- n-fixnum-tag-bits)))) (move rcx res) @@ -70,13 +69,17 @@ OKAY) + #.` (define-generic-arith-routine (- 10) (move res x) (inst sub res y) (inst jmp :no OKAY) + ;; Unbox the overflowed result, recovering the correct sign from + ;; the carry flag, then re-box as a bignum. (inst cmc) ; carry has correct sign now (inst rcr res 1) - (inst sar res 2) ; remove type bits + ,@(when (> n-fixnum-tag-bits 1) ; don't shift by 0 + '((inst sar res (1- n-fixnum-tag-bits)))) (move rcx res) @@ -85,19 +88,16 @@ OKAY) (define-generic-arith-routine (* 30) - (move rax x) ; must use eax for 64-bit result - (inst sar rax 3) ; remove *4 fixnum bias - (inst imul y) ; result in edx:eax - (inst jmp :no OKAY) ; still fixnum - - ;; zzz jrd changed edx to ebx in here, as edx isn't listed as a temp, above - ;; pfw says that loses big -- edx is target for arg x and result res - ;; note that 'edx' is not defined -- using x - (inst shrd rax x 3) ; high bits from edx - (inst sar x 3) ; now shift edx too - - (move rcx x) ; save high bits from cqo - (inst cqo) ; edx:eax <- sign-extend of eax + (move rax x) ; must use eax for 64-bit result + (inst sar rax n-fixnum-tag-bits) ; remove *8 fixnum bias + (inst imul y) ; result in edx:eax + (inst jmp :no OKAY) ; still fixnum + + (inst shrd rax x n-fixnum-tag-bits) ; high bits from edx + (inst sar x n-fixnum-tag-bits) ; now shift edx too + + (move rcx x) ; save high bits from cqo + (inst cqo) ; edx:eax <- sign-extend of eax (inst cmp x rcx) (inst jmp :e SINGLE-WORD-BIGNUM) @@ -119,33 +119,33 @@ ;;;; negation (define-assembly-routine (generic-negate - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate %negate) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) rdx-offset) - (:res res (descriptor-reg any-reg) rdx-offset) - - (:temp rax unsigned-reg rax-offset) - (:temp rcx unsigned-reg rcx-offset)) - (inst test x 7) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate %negate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) rdx-offset) + (:res res (descriptor-reg any-reg) rdx-offset) + + (:temp rax unsigned-reg rax-offset) + (:temp rcx unsigned-reg rcx-offset)) + (inst test x fixnum-tag-mask) (inst jmp :z FIXNUM) - (inst pop rax) (inst push rbp-tn) - (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes)) - (inst sub rsp-tn (fixnumize 2)) - (inst push rax) - (inst mov rcx (fixnumize 1)) ; arg count + (inst mov rbp-tn rsp-tn) + (inst sub rsp-tn (* n-word-bytes 1)) + (inst push (make-ea :qword :base rbp-tn + :disp (frame-byte-offset return-pc-save-offset))) + (inst mov rcx (fixnumize 1)) ; arg count (inst jmp (make-ea :qword - :disp (+ nil-value (static-fun-offset '%negate)))) + :disp (+ nil-value (static-fun-offset '%negate)))) FIXNUM (move res x) - (inst neg res) ; (- most-negative-fixnum) is BIGNUM + (inst neg res) ; (- most-negative-fixnum) is BIGNUM (inst jmp :no OKAY) - (inst shr res 3) ; sign bit is data - remove type bits + (inst shr res n-fixnum-tag-bits) ; sign bit is data - remove type bits (move rcx res) (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset)) @@ -156,143 +156,204 @@ ;;;; comparison (macrolet ((define-cond-assem-rtn (name translate static-fn test) - `(define-assembly-routine (,name - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate ,translate) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) rdx-offset) - (:arg y (descriptor-reg any-reg) rdi-offset) - - (:res res descriptor-reg rdx-offset) - - (:temp eax unsigned-reg rax-offset) - (:temp ecx unsigned-reg rcx-offset)) - - ;; KLUDGE: The "3" here is a mask for the bits which will be - ;; zero in a fixnum. It should have a symbolic name. (Actually, - ;; it might already have a symbolic name which the coder - ;; couldn't be bothered to use..) -- WHN 19990917 - (inst test x 7) - (inst jmp :nz TAIL-CALL-TO-STATIC-FN) - (inst test y 7) - (inst jmp :z INLINE-FIXNUM-COMPARE) - - TAIL-CALL-TO-STATIC-FN - (inst pop eax) - (inst push rbp-tn) - (inst lea rbp-tn (make-ea :qword - :base rsp-tn - :disp n-word-bytes)) - (inst sub rsp-tn (fixnumize 2)) ; FIXME: Push 2 words on stack, - ; weirdly? - (inst push eax) - (inst mov ecx (fixnumize 2)) ; FIXME: FIXNUMIZE and - ; SINGLE-FLOAT-BITS are parallel, - ; should be named parallelly. - (inst jmp (make-ea :qword - :disp (+ nil-value - (static-fun-offset ',static-fn)))) - - INLINE-FIXNUM-COMPARE - (inst cmp x y) - (inst jmp ,test RETURN-TRUE) - (inst mov res nil-value) - ;; FIXME: A note explaining this return convention, or a - ;; symbolic name for it, would be nice. (It looks as though we - ;; should be hand-crafting the same return sequence as would be - ;; produced by GENERATE-RETURN-SEQUENCE, but in that case it's - ;; not clear why we don't just jump to the end of this function - ;; to share the return sequence there. - (inst pop eax) - (inst add eax 3) - (inst jmp eax) - - RETURN-TRUE - (load-symbol res t)))) + (declare (ignorable translate static-fn)) + #+sb-assembling + `(define-assembly-routine (,name + (:return-style :none)) + ((:arg x (descriptor-reg any-reg) rdx-offset) + (:arg y (descriptor-reg any-reg) rdi-offset) + + (:temp rcx unsigned-reg rcx-offset)) + + (inst mov rcx x) + (inst or rcx y) + (inst test rcx fixnum-tag-mask) + (inst jmp :nz DO-STATIC-FUN) ; are both fixnums? + + (inst cmp x y) + (inst ret) + + DO-STATIC-FUN + (inst push rbp-tn) + (inst mov rbp-tn rsp-tn) + (inst sub rsp-tn (* n-word-bytes 3)) + (inst mov (make-ea :qword :base rsp-tn + :disp (frame-byte-offset + (+ sp->fp-offset + -3 + ocfp-save-offset))) + rbp-tn) + (inst lea rbp-tn (make-ea :qword :base rsp-tn + :disp (frame-byte-offset + (+ sp->fp-offset + -3 + ocfp-save-offset)))) + (inst mov rcx (fixnumize 2)) + (inst call (make-ea :qword + :disp (+ nil-value + (static-fun-offset ',static-fn)))) + ;; HACK: We depend on NIL having the lowest address of all + ;; static symbols (including T) + ,@(ecase test + (:l `((inst mov y (1+ nil-value)) + (inst cmp y x))) + (:g `((inst cmp x (1+ nil-value))))) + (inst pop rbp-tn) + (inst ret)) + #-sb-assembling + `(define-vop (,name) + (:translate ,translate) + (:policy :safe) + (:save-p t) + (:args (x :scs (descriptor-reg any-reg) :target rdx) + (y :scs (descriptor-reg any-reg) :target rdi)) + + (:temporary (:sc unsigned-reg :offset rdx-offset + :from (:argument 0)) + rdx) + (:temporary (:sc unsigned-reg :offset rdi-offset + :from (:argument 1)) + rdi) + + (:temporary (:sc unsigned-reg :offset rcx-offset + :from :eval) + rcx) + (:conditional ,test) + (:generator 10 + (move rdx x) + (move rdi y) + (inst mov rcx (make-fixup ',name :assembly-routine)) + (inst call rcx))))) (define-cond-assem-rtn generic-< < two-arg-< :l) (define-cond-assem-rtn generic-> > two-arg-> :g)) +#+sb-assembling (define-assembly-routine (generic-eql - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate eql) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) rdx-offset) - (:arg y (descriptor-reg any-reg) rdi-offset) - - (:res res descriptor-reg rdx-offset) - - (:temp eax unsigned-reg rax-offset) - (:temp ecx unsigned-reg rcx-offset)) - (inst cmp x y) - (inst jmp :e RETURN-T) - (inst test x 7) - (inst jmp :z RETURN-NIL) - (inst test y 7) - (inst jmp :nz DO-STATIC-FN) - - RETURN-NIL - (inst mov res nil-value) - (inst pop eax) - (inst add eax 3) - (inst jmp eax) - - DO-STATIC-FN - (inst pop eax) - (inst push rbp-tn) - (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes)) - (inst sub rsp-tn (fixnumize 2)) - (inst push eax) - (inst mov ecx (fixnumize 2)) - (inst jmp (make-ea :qword - :disp (+ nil-value (static-fun-offset 'eql)))) + (:return-style :none)) + ((:arg x (descriptor-reg any-reg) rdx-offset) + (:arg y (descriptor-reg any-reg) rdi-offset) - RETURN-T - (load-symbol res t) - ;; FIXME: I don't understand how we return from here.. - ) + (:temp rcx unsigned-reg rcx-offset)) -(define-assembly-routine (generic-= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate =) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) rdx-offset) - (:arg y (descriptor-reg any-reg) rdi-offset) - - (:res res descriptor-reg rdx-offset) - - (:temp eax unsigned-reg rax-offset) - (:temp ecx unsigned-reg rcx-offset) - ) - (inst test x 7) ; descriptor? - (inst jmp :nz DO-STATIC-FN) ; yes, do it here - (inst test y 7) ; descriptor? - (inst jmp :nz DO-STATIC-FN) - (inst cmp x y) - (inst jmp :e RETURN-T) ; ok + (inst mov rcx x) + (inst and rcx y) + (inst test rcx fixnum-tag-mask) + (inst jmp :nz DO-STATIC-FUN) - (inst mov res nil-value) - (inst pop eax) - (inst add eax 3) - (inst jmp eax) + ;; At least one fixnum + (inst cmp x y) + (inst ret) - DO-STATIC-FN - (inst pop eax) + DO-STATIC-FUN (inst push rbp-tn) - (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes)) - (inst sub rsp-tn (fixnumize 2)) - (inst push eax) - (inst mov ecx (fixnumize 2)) - (inst jmp (make-ea :qword - :disp (+ nil-value (static-fun-offset 'two-arg-=)))) + (inst mov rbp-tn rsp-tn) + (inst sub rsp-tn (* n-word-bytes 3)) + (inst mov (make-ea :qword :base rsp-tn + :disp (frame-byte-offset + (+ sp->fp-offset + -3 + ocfp-save-offset))) + rbp-tn) + (inst lea rbp-tn (make-ea :qword :base rsp-tn + :disp (frame-byte-offset + (+ sp->fp-offset + -3 + ocfp-save-offset)))) + (inst mov rcx (fixnumize 2)) + (inst call (make-ea :qword + :disp (+ nil-value (static-fun-offset 'eql)))) + (load-symbol y t) + (inst cmp x y) + (inst pop rbp-tn) + (inst ret)) + +#-sb-assembling +(define-vop (generic-eql) + (:translate eql) + (:policy :safe) + (:save-p t) + (:args (x :scs (descriptor-reg any-reg) :target rdx) + (y :scs (descriptor-reg any-reg) :target rdi)) + + (:temporary (:sc unsigned-reg :offset rdx-offset + :from (:argument 0)) + rdx) + (:temporary (:sc unsigned-reg :offset rdi-offset + :from (:argument 1)) + rdi) + + (:temporary (:sc unsigned-reg :offset rcx-offset + :from :eval) + rcx) + (:conditional :e) + (:generator 10 + (move rdx x) + (move rdi y) + (inst mov rcx (make-fixup 'generic-eql :assembly-routine)) + (inst call rcx))) + +#+sb-assembling +(define-assembly-routine (generic-= + (:return-style :none)) + ((:arg x (descriptor-reg any-reg) rdx-offset) + (:arg y (descriptor-reg any-reg) rdi-offset) - RETURN-T - (load-symbol res t)) + (:temp rcx unsigned-reg rcx-offset)) + (inst mov rcx x) + (inst or rcx y) + (inst test rcx fixnum-tag-mask) + (inst jmp :nz DO-STATIC-FUN) + ;; Both fixnums + (inst cmp x y) + (inst ret) + DO-STATIC-FUN + (inst push rbp-tn) + (inst mov rbp-tn rsp-tn) + (inst sub rsp-tn (* n-word-bytes 3)) + (inst mov (make-ea :qword :base rsp-tn + :disp (frame-byte-offset + (+ sp->fp-offset + -3 + ocfp-save-offset))) + rbp-tn) + (inst lea rbp-tn (make-ea :qword :base rsp-tn + :disp (frame-byte-offset + (+ sp->fp-offset + -3 + ocfp-save-offset)))) + + (inst mov rcx (fixnumize 2)) + (inst call (make-ea :qword + :disp (+ nil-value (static-fun-offset 'two-arg-=)))) + (load-symbol y t) + (inst cmp x y) + (inst pop rbp-tn) + (inst ret)) + +#-sb-assembling +(define-vop (generic-=) + (:translate =) + (:policy :safe) + (:save-p t) + (:args (x :scs (descriptor-reg any-reg) :target rdx) + (y :scs (descriptor-reg any-reg) :target rdi)) + + (:temporary (:sc unsigned-reg :offset rdx-offset + :from (:argument 0)) + rdx) + (:temporary (:sc unsigned-reg :offset rdi-offset + :from (:argument 1)) + rdi) + + (:temporary (:sc unsigned-reg :offset rcx-offset + :from :eval) + rcx) + (:conditional :e) + (:generator 10 + (move rdx x) + (move rdi y) + (inst mov rcx (make-fixup 'generic-= :assembly-routine)) + (inst call rcx)))