X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fassembly%2Fx86-64%2Farith.lisp;h=6a1fe24ddb96f9070730c8e3d3b096a0059432d4;hb=37b1ed8e9b6faa84832b8251998b5d0eb1f6b307;hp=3e839923758f57cf06d3ecd50ecacaf2b52a0c64;hpb=2cd35e262d4be338e419114137ebf75e36e950f9;p=sbcl.git

diff --git a/src/assembly/x86-64/arith.lisp b/src/assembly/x86-64/arith.lisp
index 3e83992..6a1fe24 100644
--- a/src/assembly/x86-64/arith.lisp
+++ b/src/assembly/x86-64/arith.lisp
@@ -21,9 +21,7 @@
                                         (: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)
+                 (:arg y (descriptor-reg any-reg) rdi-offset)
 
                  (:res res (descriptor-reg any-reg) rdx-offset)
 
@@ -36,17 +34,16 @@
                 (inst jmp :nz DO-STATIC-FUN)    ; no - do generic
 
                 ,@body
-                (inst clc)
+                (inst clc) ; single-value return
                 (inst ret)
 
                 DO-STATIC-FUN
-                (inst pop rax)
+                ;; Same as: (inst enter (* n-word-bytes 1))
                 (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 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
@@ -54,12 +51,16 @@
                                         (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)
 
@@ -68,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)
 
@@ -127,11 +132,11 @@
   (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 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))))
@@ -151,64 +156,86 @@
 ;;;; comparison
 
 (macrolet ((define-cond-assem-rtn (name translate static-fn test)
+               (declare (ignorable translate static-fn))
+             #+sb-assembling
              `(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)
+                                        (:return-style :none))
+                  ((:arg x (descriptor-reg any-reg) rdx-offset)
+                   (:arg y (descriptor-reg any-reg) rdi-offset)
 
-                 (:temp eax unsigned-reg rax-offset)
-                 (:temp ecx unsigned-reg rcx-offset))
+                   (:temp rcx unsigned-reg rcx-offset))
 
-                (inst mov ecx x)
-                (inst or ecx y)
-                (inst test ecx fixnum-tag-mask)
-                (inst jmp :nz DO-STATIC-FUN)
+                (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)
-                (load-symbol res t)
-                (inst mov eax nil-value)
-                (inst cmov ,test res eax)
-                (inst clc)   ; single-value return
                 (inst ret)
 
                 DO-STATIC-FUN
-                (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)))))))
-
-  (define-cond-assem-rtn generic-< < two-arg-< :ge)
-  (define-cond-assem-rtn generic-> > two-arg-> :le))
-
+                (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))
+                          (:return-style :none))
                          ((:arg x (descriptor-reg any-reg) rdx-offset)
                           (:arg y (descriptor-reg any-reg) rdi-offset)
 
-                          (:res res descriptor-reg rdx-offset)
-
-                          (:temp rax unsigned-reg rax-offset)
                           (:temp rcx unsigned-reg rcx-offset))
+
   (inst mov rcx x)
   (inst and rcx y)
   (inst test rcx fixnum-tag-mask)
@@ -216,34 +243,62 @@
 
   ;; At least one fixnum
   (inst cmp x y)
-  (load-symbol res t)
-  (inst mov rax nil-value)
-  (inst cmov :ne res rax)
-  (inst clc)
   (inst ret)
 
   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)
+  (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 jmp (make-ea :qword
-                     :disp (+ nil-value (static-fun-offset 'eql)))))
-
+  (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-=
-                          (:cost 10)
-                          (:return-style :full-call)
-                          (:policy :safe)
-                          (:translate =)
-                          (:save-p t))
+                          (:return-style :none))
                          ((:arg x (descriptor-reg any-reg) rdx-offset)
                           (:arg y (descriptor-reg any-reg) rdi-offset)
 
-                          (:res res descriptor-reg rdx-offset)
-
-                          (:temp rax unsigned-reg rax-offset)
                           (:temp rcx unsigned-reg rcx-offset))
   (inst mov rcx x)
   (inst or rcx y)
@@ -252,20 +307,53 @@
 
   ;; Both fixnums
   (inst cmp x y)
-  (load-symbol res t)
-  (inst mov rax nil-value)
-  (inst cmov :ne res rax)
-  (inst clc)
   (inst ret)
 
   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)
-  (inst mov rcx (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 '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)))