Faster EQL for bignums on x86-64

make-config.sh

@@ -640,7 +640,7 @@ elif [ "$sbcl_arch" = "x86-64" ]; then
     printf ' :stack-allocatable-closures :stack-allocatable-vectors' >> $ltf
     printf ' :stack-allocatable-lists :stack-allocatable-fixed-objects' >> $ltf
     printf ' :alien-callbacks :cycle-counter :complex-float-vops' >> $ltf
-    printf ' :float-eql-vops :inline-constants :memory-barrier-vops' >> $ltf
+    printf ' :float-eql-vops :integer-eql-vop :inline-constants :memory-barrier-vops' >> $ltf
     printf ' :multiply-high-vops :sb-simd-pack :ash-right-vops :symbol-info-vops' >> $ltf
 elif [ "$sbcl_arch" = "mips" ]; then
     printf ' :cheneygc :linkage-table' >> $ltf

package-data-list.lisp-expr

@@ -1411,7 +1411,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "CONTAINS-UNKNOWN-TYPE-P"
                "%COS" "%COS-QUICK"
                "%COSH" "%DATA-VECTOR-AND-INDEX" "%DEPOSIT-FIELD"
-               "%DOUBLE-FLOAT" "%DPB" "%EQL"
+               "%DOUBLE-FLOAT" "%DPB" "%EQL" "%EQL/INTEGER"
                "%EXIT"
                "%EXP" "%EXPM1"
                "%FIND-POSITION"

src/assembly/x86-64/arith.lisp

@@ -415,3 +415,62 @@
          done))))
   (def-it unsigned-byte-64-count 14 unsigned-reg unsigned-num)
   (def-it positive-fixnum-count 13 any-reg positive-fixnum))
+
+;;; EQL for integers that are either fixnum or bignum
+
+;; The restriction on use of this assembly routine can't be expressed a
+;; constraints on vop args: it may be called when at *least* one arg
+;; is known to be an integer; the other can be anything.
+;
+;; Logic: we succeed quickly in the EQ case when possible.
+;; Otherwise, check if both are OTHER-POINTER objects, failing if not.
+;; Given that at least one is an integer, and both are OTHER-POINTERs,
+;; then if their widetags match, both are BIGNUMs to be compared word-for-word.
+;;
+;; If you call this with two other-pointer objects with
+;; the same widetag, but not bignum-widetag, the behavior is undefined.
+;;
+(define-assembly-routine (%eql/integer
+                          (:translate %eql/integer)
+                          ;; :safe would imply signaling an error
+                          ;; if the args are not integer, which this doesn't.
+                          (:policy :fast-safe)
+                          (:conditional :e)
+                          (:cost 10)
+                          (:call-temps rcx))
+                         ((:arg x (descriptor-reg any-reg) rdx-offset)
+                          (:arg y (descriptor-reg any-reg) rdi-offset)
+                          (:temp rcx unsigned-reg rcx-offset)
+                          (:temp rax unsigned-reg rax-offset))
+  (inst cmp x y)
+  (inst jmp :e done) ; Z condition flag contains the answer
+  ;; check that both have other-pointer-lowtag
+  (inst lea (reg-in-size rax :dword)
+        (make-ea :dword :base x :disp (- other-pointer-lowtag)))
+  (inst lea (reg-in-size rcx :dword)
+        (make-ea :dword :base y :disp (- other-pointer-lowtag)))
+  (inst or (reg-in-size rax :dword) (reg-in-size rcx :dword))
+  (inst test (reg-in-size rax :byte) lowtag-mask)
+  (inst jmp :ne done)
+  ;; Compare the entire header word, ensuring that if at least one
+  ;; argument is a bignum, then both are.
+  (inst mov rcx (make-ea :qword :base x :disp (- other-pointer-lowtag)))
+  (inst cmp rcx (make-ea :qword :base y :disp (- other-pointer-lowtag)))
+  (inst jmp :ne done)
+  (inst shr rcx n-widetag-bits)
+  ;; can you have 0 payload words? probably not, but let's be safe here.
+  (inst jrcxz done)
+  loop
+  (inst mov rax (make-ea :qword :base x :disp (- other-pointer-lowtag)
+                         :index rcx :scale 8))
+  (inst cmp rax (make-ea :qword :base y :disp (- other-pointer-lowtag)
+                         :index rcx :scale 8))
+  ;; These next 3 instructions are the equivalent of "LOOPNZ LOOP"
+  ;; but had significantly better performance for me, consistent with claims
+  ;; of most optimization guides saying that LOOP was deliberately pessimized
+  ;; because of its use in timing-related code in the win32 kernel.
+  (inst jmp :ne done)
+  (inst dec rcx)
+  (inst jmp :ne loop)
+  ;; If the Z flag is set, the integers were EQL
+  done)

src/code/pred.lisp

@@ -242,6 +242,10 @@
       (if (or (typep obj2 'fixnum)
               (not (typep obj2 'number)))
           nil
+          ;; I would think that we could do slightly better here by testing that
+          ;; both objs are OTHER-POINTER-P with equal %OTHER-POINTER-WIDETAGs.
+          ;; Then dispatch on obj2 and elide the TYPEP on obj1 using TRULY-THE.
+          ;; Also would need to deal with immediate single-float for 64-bit.
           (macrolet ((foo (&rest stuff)
                        `(typecase obj2
                           ,@(mapcar (lambda (foo)
@@ -257,8 +261,8 @@
              #!+long-float
              (long-float eql)
              (bignum
-              (lambda (x y)
-                (zerop (bignum-compare x y))))
+              #!-integer-eql-vop (lambda (x y) (zerop (bignum-compare x y)))
+              #!+integer-eql-vop eql) ; will become %eql/integer
              (ratio
               (lambda (x y)
                 (and (eql (numerator x) (numerator y))

src/compiler/fndb.lisp

@@ -74,7 +74,8 @@
                 sb!xc:packagep functionp compiled-function-p not)
   (t) boolean (movable foldable flushable))
 
-(defknown (eq eql) (t t) boolean (movable foldable flushable commutative))
+(defknown (eq eql %eql/integer) (t t) boolean
+  (movable foldable flushable commutative))
 (defknown (equal equalp) (t t) boolean (foldable flushable recursive))
 
 #!+(or x86 x86-64 arm)

src/compiler/srctran.lisp

@@ -3837,6 +3837,7 @@
   "convert to simpler equality predicate"
   (let ((x-type (lvar-type x))
         (y-type (lvar-type y))
+        #!+integer-eql-vop (int-type (specifier-type 'integer))
         (char-type (specifier-type 'character)))
     (cond
       ((same-leaf-ref-p x y) t)
@@ -3847,6 +3848,9 @@
        '(char= x y))
       ((or (eq-comparable-type-p x-type) (eq-comparable-type-p y-type))
        '(eq y x))
+      #!+integer-eql-vop
+      ((or (csubtypep x-type int-type) (csubtypep y-type int-type))
+       '(%eql/integer x y))
       (t
        (give-up-ir1-transform)))))
 

src/compiler/x86-64/arith.lisp

@@ -1321,12 +1321,12 @@ constant shift greater than word length")))
   (define-conditional-vop > :g :a :le :be))
 
 (define-vop (fast-if-eql/signed fast-conditional/signed)
-  (:translate eql)
+  (:translate eql %eql/integer)
   (:generator 6
     (inst cmp x y)))
 
 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
-  (:translate eql)
+  (:translate eql %eql/integer)
   (:generator 5
     (cond ((and (sc-is x signed-reg) (zerop y))
            (inst test x x))  ; smaller instruction
@@ -1334,12 +1334,12 @@ constant shift greater than word length")))
            (inst cmp x (constantize y))))))
 
 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
-  (:translate eql)
+  (:translate eql %eql/integer)
   (:generator 6
     (inst cmp x y)))
 
 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
-  (:translate eql)
+  (:translate eql %eql/integer)
   (:generator 5
     (cond ((and (sc-is x unsigned-reg) (zerop y))
            (inst test x x))  ; smaller instruction
@@ -1362,7 +1362,7 @@ constant shift greater than word length")))
          (y :scs (any-reg control-stack)))
   (:arg-types tagged-num tagged-num)
   (:note "inline fixnum comparison")
-  (:translate eql)
+  (:translate eql %eql/integer)
   (:generator 4
     (inst cmp x y)))
 
@@ -1380,7 +1380,7 @@ constant shift greater than word length")))
   (:info y)
   (:conditional :e)
   (:policy :fast-safe)
-  (:translate eql)
+  (:translate eql %eql/integer)
   (:generator 2
     (cond ((and (sc-is x any-reg descriptor-reg) (zerop y))
            (inst test x x))  ; smaller instruction