Use new MAP-RESTARTS in FIND-RESTART, COMPUTE-RESTARTS; fix FIND-RESTART

[sbcl.git] / src / compiler / x86-64 / arith.lisp

diff --git a/src/compiler/x86-64/arith.lisp b/src/compiler/x86-64/arith.lisp
index 311eb78..f455bff 100644 (file)
--- a/src/compiler/x86-64/arith.lisp
+++ b/src/compiler/x86-64/arith.lisp
@@ -1328,13 +1328,17 @@ constant shift greater than word length")))
                         (:translate ,tran)
                         (:conditional ,(if signed cond unsigned))
                         (:generator ,cost
-                                    (inst cmp x
-                                          ,(case suffix
-                                             (-c/fixnum
-                                                `(constantize (fixnumize y)))
-                                             ((-c/signed -c/unsigned)
-                                                `(constantize y))
-                                             (t 'y))))))
+                          (cond ((and (sc-is x any-reg signed-reg unsigned-reg)
+                                      (eql y 0))
+                                 (inst test x x))
+                                (t
+                                 (inst cmp x
+                                       ,(case suffix
+                                          (-c/fixnum
+                                           `(constantize (fixnumize y)))
+                                          ((-c/signed -c/unsigned)
+                                           `(constantize y))
+                                          (t 'y))))))))
                    '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
 ;                  '(/fixnum  /signed  /unsigned)
                    '(4 3 6 5 6 5)
@@ -1505,6 +1509,23 @@ constant shift greater than word length")))
   (def - t)
   (def * t))
 
+(define-modular-fun %negate-mod64 (x) %negate :untagged nil 64)
+(define-vop (%negate-mod64)
+  (:translate %negate-mod64)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg) :target r))
+  (:arg-types unsigned-num)
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 3
+    (move r x)
+    (inst neg r)))
+
+(define-modular-fun %negate-modfx (x) %negate :tagged t #.(- n-word-bits
+                                                             n-fixnum-tag-bits))
+(define-vop (%negate-modfx fast-negate/fixnum)
+  (:translate %negate-modfx))
+
 (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
              fast-ash-c/unsigned=>unsigned)
   (:translate ash-left-mod64))
@@ -1632,7 +1653,7 @@ constant shift greater than word length")))
 
 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
   (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
-(define-full-reffer+offset bignum--ref-with-offset * bignum-digits-offset
+(define-full-reffer+offset bignum-ref-with-offset * bignum-digits-offset
   other-pointer-lowtag (unsigned-reg) unsigned-num
   sb!bignum:%bignum-ref-with-offset)
 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
@@ -1890,6 +1911,77 @@ constant shift greater than word length")))
     (move result digit)
     (move ecx count)
     (inst shl result :cl)))
+
+(define-vop (logand-bignum/c)
+  (:translate logand)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg)))
+  (:arg-types bignum (:constant word))
+  (:results (r :scs (unsigned-reg)))
+  (:info mask)
+  (:result-types unsigned-num)
+  (:generator 4
+    (let ((mask (constantize mask)))
+      (cond ((or (integerp mask)
+                 (location= x r))
+             (loadw r x bignum-digits-offset other-pointer-lowtag)
+             (unless (eql mask -1)
+               (inst and r mask)))
+            (t
+             (inst mov r mask)
+             (inst and r (make-ea-for-object-slot x
+                                                  bignum-digits-offset
+                                                  other-pointer-lowtag)))))))
+
+;; Specialised mask-signed-field VOPs.
+(define-vop (mask-signed-field-word/c)
+  (:translate sb!c::mask-signed-field)
+  (:policy :fast-safe)
+  (:args (x :scs (signed-reg unsigned-reg) :target r))
+  (:arg-types (:constant (integer 0 64)) untagged-num)
+  (:results (r :scs (signed-reg)))
+  (:result-types signed-num)
+  (:info width)
+  (:generator 3
+    (cond ((zerop width)
+           (zeroize r))
+          ((= width 64)
+           (move r x))
+          ((member width '(32 16 8))
+           (inst movsx r (reg-in-size x (ecase width
+                                             (32 :dword)
+                                             (16 :word)
+                                             (8  :byte)))))
+          (t
+           (move r x)
+           (let ((delta (- n-word-bits width)))
+             (inst shl r delta)
+             (inst sar r delta))))))
+
+(define-vop (mask-signed-field-bignum/c)
+  (:translate sb!c::mask-signed-field)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg) :target r))
+  (:arg-types (:constant (integer 0 64)) bignum)
+  (:results (r :scs (signed-reg)))
+  (:result-types signed-num)
+  (:info width)
+  (:generator 4
+    (cond ((zerop width)
+           (zeroize r))
+          ((member width '(8 16 32 64))
+           (ecase width
+             (64 (loadw r x bignum-digits-offset other-pointer-lowtag))
+             ((32 16 8)
+              (inst movsx r (make-ea (ecase width (32 :dword) (16 :word) (8 :byte))
+                                     :base x
+                                     :disp (- (* bignum-digits-offset n-word-bytes)
+                                              other-pointer-lowtag))))))
+          (t
+           (loadw r x bignum-digits-offset other-pointer-lowtag)
+           (let ((delta (- n-word-bits width)))
+             (inst shl r delta)
+             (inst sar r delta))))))
 \f
 ;;;; static functions