x86-64: shorten code size for a few word-sized math vops

* Adjust register lifetimes to possibly eliminate a physical move
* Call out to an asm routine for consing new bignums
* Never overallocate the bignum; use the exact request size
* Insert allocation profiler instrumentation as needed
* Add a vop for word x word -> integer

src/assembly/x86-64/alloc.lisp

@@ -61,6 +61,79 @@
                  ONE-WORD-BIGNUM
                  (alloc-other bignum-widetag (+ bignum-digits-offset 1) number nil nil nil)
                  (popw number bignum-digits-offset other-pointer-lowtag))))))
+     (from-digits (reg)
+       ;; stack args:
+       ;; +24   is-two-digit [passed in 1 byte]
+       ;; +16   high-digit
+       ;;  +8   low-digit
+       ;; rsp : return-pc
+       ;;       saved-RAX if needed
+       (let* ((result (symbolicate reg "-TN"))
+              ;; If result is R12, then allocate to RAX since INSTRUMENT-ALLOC can not
+              ;; use R12 as the temp due to longer encoding and self-modifying code.
+              (rax-temp (and (eq reg 'r12) (policy nil (> sb-c::instrument-consing 1))))
+              (alloc (if rax-temp 'rax-tn (symbolicate reg "-TN"))))
+         `(define-assembly-routine (,(symbolicate "BIGNUM-TO-" reg)
+                                     (:return-style :none))
+              ()
+            (inst cmp :byte (ea 24 rsp-tn) 0)
+            ,@(if rax-temp '((inst push rax-tn)))
+            (inst jmp :e one-word-bignum)
+            (alloc-other bignum-widetag (+ bignum-digits-offset 2) ,alloc nil nil nil)
+            ,@(when rax-temp '((inst mov r12-tn rax-tn) (inst pop rax-tn)))
+            (inst movdqu float0-tn (ea 8 rsp-tn))
+            (inst movdqu (ea (- (ash 1 word-shift) other-pointer-lowtag) ,result) float0-tn)
+            (inst ret 24) ; pop args
+            ONE-WORD-BIGNUM
+            (alloc-other bignum-widetag (+ bignum-digits-offset 1) ,alloc nil nil nil)
+            ,@(when rax-temp '((inst mov r12-tn rax-tn) (inst pop rax-tn)))
+            (inst movq float0-tn (ea 8 rsp-tn))
+            (inst movq (ea (- (ash 1 word-shift) other-pointer-lowtag) ,result) float0-tn)
+            (inst ret 24))))
+     ;; "from unsigned" might need to allocate 3 digits, but it receives only high:low
+     ;; because the highest digit if needed must be all 0.
+     (from-digits-unsigned (reg)
+       ;; stack args:
+       ;; +24   is-two-or-three-digit [passed in 1 byte]
+       ;; +16   high-digit
+       ;;  +8   low-digit
+       ;; rsp : return-pc
+       ;;       saved-RAX if needed
+       (let* ((result (symbolicate reg "-TN"))
+              ;; If result is R12, then allocate to RAX since INSTRUMENT-ALLOC can not
+              ;; use R12 as the temp due to longer encoding and self-modifying code.
+              (rax-temp (and (eq reg 'r12) (policy nil (> sb-c::instrument-consing 1))))
+              (alloc (if rax-temp 'rax-tn (symbolicate reg "-TN"))))
+         `(define-assembly-routine (,(symbolicate "+BIGNUM-TO-" reg)
+                                     (:return-style :none))
+              ()
+            (inst cmp :byte (ea 24 rsp-tn) 0)
+            (inst jmp :e one-word-bignum)
+            (inst test :byte (ea (+ 16 7) rsp-tn) #x80) ; sign bit
+            (inst jmp :z two-word-bignum)
+            ;; THREE-WORD-BIGNUM
+            ,@(if rax-temp '((inst push rax-tn)))
+            (alloc-other bignum-widetag (+ bignum-digits-offset 3) ,alloc nil nil nil)
+            ,@(when rax-temp '((inst mov r12-tn rax-tn) (inst pop rax-tn)))
+            (inst movdqu float0-tn (ea 8 rsp-tn))
+            (inst movdqu (ea (- (ash 1 word-shift) other-pointer-lowtag) ,result) float0-tn)
+            ;; don't assume prezeroed unboxed pages
+            (inst mov :qword (ea (- (ash 3 word-shift) other-pointer-lowtag) ,result) 0)
+            (inst ret 24) ; pop args
+            TWO-WORD-BIGNUM
+            ,@(if rax-temp '((inst push rax-tn)))
+            (alloc-other bignum-widetag (+ bignum-digits-offset 2) ,alloc nil nil nil)
+            ,@(when rax-temp '((inst mov r12-tn rax-tn) (inst pop rax-tn)))
+            (inst movdqu float0-tn (ea 8 rsp-tn))
+            (inst movdqu (ea (- (ash 1 word-shift) other-pointer-lowtag) ,result) float0-tn)
+            (inst ret 24)
+            ONE-WORD-BIGNUM
+            ,@(if rax-temp '((inst push rax-tn)))
+            (alloc-other bignum-widetag (+ bignum-digits-offset 1) ,alloc nil nil nil)
+            ,@(when rax-temp '((inst mov r12-tn rax-tn) (inst pop rax-tn)))
+            (inst movq float0-tn (ea 8 rsp-tn))
+            (inst movq (ea (- (ash 1 word-shift) other-pointer-lowtag) ,result) float0-tn)
+            (inst ret 24))))
      (define (op)
        ;; R13 is usually the thread register, but might not be
        `(progn
@@ -69,6 +142,8 @@
                                #+gs-seg r13
                                r14 r15)
                   collect `(,op ,reg)))))
+  (define from-digits)
+  (define from-digits-unsigned)
   (define signed)
   (define unsigned))
 

src/assembly/x86-64/support.lisp

@@ -30,6 +30,17 @@
              (make-fixup routine :assembly-routine)
              (ea (make-fixup routine :assembly-routine*)))))
 
+(defmacro invoke-reg-specific-asm-routine (node prefix tn &optional (suffix ""))
+  `(invoke-asm-routine
+    'call
+    (aref ,(map 'vector
+                (lambda (x)
+                  (unless (member x '(rsp rbp) :test 'string=)
+                    (symbolicate prefix x suffix)))
+                +qword-register-names+)
+          (tn-offset ,tn))
+    ,node))
+
 (defun generate-call-sequence (name style vop options)
   (declare (ignore options))
   (ecase style

src/compiler/x86-64/arith.lisp

@@ -582,16 +582,29 @@
       (inst imul r x y)
       (inst jmp :o error))))
 
+(defun wordpair-to-bignum (result flag low high node)
+  (inst push flag)
+  (inst push high)
+  (inst push low)
+  (invoke-reg-specific-asm-routine node "BIGNUM-TO-" result))
+(defun unsigned-wordpair-to-bignum (result flag low high node)
+  (inst push flag)
+  (inst push high)
+  (inst push low)
+  (invoke-reg-specific-asm-routine node "+BIGNUM-TO-" result))
+
 (define-vop (*/signed=>integer)
   (:translate *)
   (:args (x :scs (signed-reg) :target rax)
-         (y :scs (signed-reg) :target header))
+         (y :scs (signed-reg)))
   (:arg-types signed-num signed-num)
   (:temporary (:sc signed-reg :offset rax-offset :from (:argument 0))
               rax)
   (:temporary (:sc signed-reg :offset rdx-offset :from (:argument 1))
               rdx)
-  (:temporary (:sc signed-reg :from (:argument 2)) header alloc-temp)
+  (:temporary (:sc signed-reg :from :eval) twodigit)
+  (:temporary (:sc complex-double-reg :offset 0) scratch)
+  (:ignore scratch)
   (:results (r :scs (descriptor-reg)))
   (:policy :fast-safe)
   (:vop-var vop)
@@ -599,139 +612,150 @@
   (:generator 10
     (move rax x)
     (inst imul y)
-    (inst mov header (bignum-header-for-length 2))
+    (inst mov :byte twodigit 1) ; = "yes"
     (inst jmp :o allocate)
     (move r rax)
     (inst shl r 1)
     (inst jmp :no DONE)
-    (inst mov header (bignum-header-for-length 1))
-    #+bignum-assertions
-    (zeroize rdx)
+    (zeroize twodigit) ; = "no"
     allocate
-    (pseudo-atomic ()
-      (allocation nil (pad-data-block (+ 2 bignum-digits-offset)) 0
-                  r node alloc-temp thread-tn)
-      (storew header r)
-      (storew rax r 1)
-      (storew rdx r 2)
-      (inst or r other-pointer-lowtag))
+    (wordpair-to-bignum r twodigit rax rdx node)
     DONE))
 
 (define-vop (+/signed=>integer)
   (:translate +)
-  (:args (x :scs (signed-reg))
+  (:args (x :scs (signed-reg) :target low)
          (y :scs (signed-reg)))
   (:arg-types signed-num signed-num)
-  (:temporary (:sc signed-reg) high low)
-  (:temporary (:sc signed-reg :from (:argument 2)) header alloc-temp)
+  (:temporary (:sc signed-reg :from (:argument 0)) low)
+  (:temporary (:sc signed-reg :from :eval) high twodigit)
+  (:temporary (:sc complex-double-reg :offset 0) scratch)
+  (:ignore scratch)
   (:results (r :scs (descriptor-reg)))
   (:policy :fast-safe)
   (:vop-var vop)
   (:node-var node)
   (:generator 7
-    (inst mov low x)
+    (move low x)
     (inst add low y)
-    (inst set :c high)
-    (inst mov header (bignum-header-for-length 2))
+    (inst mov :byte twodigit 1)
     (inst jmp :o allocate)
     (move r low)
     (inst shl r 1)
     (inst jmp :no DONE)
-    (inst mov header (bignum-header-for-length 1))
+    (zeroize twodigit)
     allocate
-    (inst movzx '(:byte :dword) high high)
-    (inst neg high)
-    (pseudo-atomic ()
-      (allocation nil (pad-data-block (+ 2 bignum-digits-offset)) 0
-                  r node alloc-temp thread-tn)
-      (storew header r)
-      (storew low r 1)
-      (storew high r 2)
-      (inst or r other-pointer-lowtag))
+    ;; high := CF broadcast into all bits. Ignored if single-digit
+    (inst sbb high high)
+    (wordpair-to-bignum r twodigit low high node)
     DONE))
 
 (define-vop (-/signed=>integer)
   (:translate -)
-  (:args (x :scs (signed-reg))
+  (:args (x :scs (signed-reg) :target low)
          (y :scs (signed-reg)))
   (:arg-types signed-num signed-num)
-  (:temporary (:sc signed-reg) high low)
-  (:temporary (:sc signed-reg :from (:argument 2)) header alloc-temp)
+  (:temporary (:sc signed-reg :from (:argument 0)) low)
+  (:temporary (:sc signed-reg :from :eval) high twodigit)
+  (:temporary (:sc complex-double-reg :offset 0) scratch)
+  (:ignore scratch)
   (:results (r :scs (descriptor-reg)))
   (:policy :fast-safe)
   (:vop-var vop)
   (:node-var node)
   (:generator 7
-    (inst mov low x)
+    (move low x)
     (inst sub low y)
-    (inst set :nc high)
-    (inst mov header (bignum-header-for-length 2))
+    (inst mov :byte twodigit 1)
     (inst jmp :o allocate)
     (move r low)
     (inst shl r 1)
     (inst jmp :no DONE)
-    (inst mov header (bignum-header-for-length 1))
+    (zeroize twodigit)
     allocate
-    (inst movzx '(:byte :dword) high high)
-    (inst neg high)
-    (pseudo-atomic ()
-      (allocation nil (pad-data-block (+ 2 bignum-digits-offset)) 0
-                  r node alloc-temp thread-tn)
-      (storew header r)
-      (storew low r 1)
-      (storew high r 2)
-      (inst or r other-pointer-lowtag))
+    (inst cmc)
+    (inst sbb high high)
+    (wordpair-to-bignum r twodigit low high node)
+    DONE))
+
+(define-vop (*/unsigned=>integer)
+  (:translate *)
+  (:args (x :scs (unsigned-reg) :target rax)
+         (y :scs (unsigned-reg)))
+  (:arg-types unsigned-num unsigned-num)
+  (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0)) rax)
+  (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 1)) rdx)
+  (:temporary (:sc signed-reg :from (:argument 2)) multidigit)
+  (:temporary (:sc complex-double-reg :offset 0) scratch)
+  (:ignore scratch)
+  (:results (r :scs (descriptor-reg)))
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:node-var node)
+  (:generator 10
+    (move rax x)
+    (inst mul y)
+    (inst mov :byte multidigit 1) ; might need 2 or 3 digits to represent
+    ;; OF implies RDX nonzero. Sign bit of RDX gets tested in asm routine
+    (inst jmp :o allocate)
+    (move r rax)
+    (inst shl r 1) ; n-fixnum-tag-bits
+    ;; If we shifted out a 1 bit from the low digit, then it's a 2-digit bignum
+    (inst jmp :c allocate)
+    ;; If not-CF and not-OF then the top 2 bits of the low digit are both zero
+    ;; and the result is a fixnum, otherwise a 1-digit bignumm
+    (inst jmp :no DONE)
+    (zeroize multidigit)
+    allocate
+    (unsigned-wordpair-to-bignum r multidigit rax rdx node)
     DONE))
 
 (define-vop (+/unsigned=>integer)
   (:translate +)
-  (:args (x :scs (unsigned-reg))
+  (:args (x :scs (unsigned-reg) :target low)
          (y :scs (unsigned-reg)))
   (:arg-types unsigned-num unsigned-num)
-  (:temporary (:sc unsigned-reg) high low)
-  (:temporary (:sc unsigned-reg :from (:argument 2)) header alloc-temp)
+  (:temporary (:sc unsigned-reg :from (:argument 0)) low)
+  (:temporary (:sc unsigned-reg :from :eval) high twodigit)
+  (:temporary (:sc complex-double-reg :offset 0) scratch)
+  (:ignore scratch)
   (:results (r :scs (descriptor-reg)))
   (:policy :fast-safe)
   (:vop-var vop)
   (:node-var node)
   (:generator 8
-    (inst mov low x)
+    (move low x)
     (inst add low y)
     (inst set :c high)
-    (inst mov header (bignum-header-for-length 2))
+    (inst mov :byte twodigit 1)
     (inst jmp :c allocate)
     (inst jmp :s allocate)
     (move r low)
     (inst shl r 1)
     (inst jmp :no DONE)
-    (inst mov header (bignum-header-for-length 1))
+    (zeroize twodigit)
     allocate
     (inst movzx '(:byte :dword) high high)
-    (pseudo-atomic ()
-      (allocation nil (pad-data-block (+ 2 bignum-digits-offset)) 0
-                  r node alloc-temp thread-tn)
-      (storew header r)
-      (storew low r 1)
-      (storew high r 2)
-      (inst or r other-pointer-lowtag))
+    (wordpair-to-bignum r twodigit low high node)
     DONE))
 
 (define-vop (-/unsigned=>integer)
   (:translate -)
-  (:args (x :scs (unsigned-reg))
+  (:args (x :scs (unsigned-reg) :target low)
          (y :scs (unsigned-reg)))
   (:arg-types unsigned-num unsigned-num)
-  (:temporary (:sc unsigned-reg) high low)
-  (:temporary (:sc unsigned-reg :from (:argument 2)) header alloc-temp)
+  (:temporary (:sc unsigned-reg :from (:argument 0)) low)
+  (:temporary (:sc unsigned-reg :from :eval) high twodigit)
+  (:temporary (:sc complex-double-reg :offset 0) scratch)
+  (:ignore scratch)
   (:results (r :scs (descriptor-reg)))
   (:policy :fast-safe)
   (:vop-var vop)
   (:node-var node)
   (:generator 8
-    (inst mov low x)
+    (move low x)
     (inst sub low y)
-    (inst set :c high)
-    (inst mov header (bignum-header-for-length 2))
+    (inst mov :byte twodigit 1)
 
     (inst jmp :c negative)
     (inst jmp :s allocate)
@@ -743,17 +767,10 @@
     (move r low)
     (inst shl r 1)
     (inst jmp :no DONE)
-    (inst mov header (bignum-header-for-length 1))
+    (zeroize twodigit)
     allocate
-    (inst movzx '(:byte :dword) high high)
-    (inst neg high)
-    (pseudo-atomic ()
-      (allocation nil (pad-data-block (+ 2 bignum-digits-offset)) 0
-                  r node alloc-temp thread-tn)
-      (storew header r)
-      (storew low r 1)
-      (storew high r 2)
-      (inst or r other-pointer-lowtag))
+    (inst sbb high high)
+    (wordpair-to-bignum r twodigit low high node)
     DONE))
 
 (define-vop ()

tests/heapwalk.impure.lisp

@@ -30,7 +30,12 @@
 ;;; As a precondition to asserting that heap walking did not
 ;;; visit an alleged cons that is a filler object,
 ;;; assert that there is the telltale pattern (if applicable).
-#+(or arm64 x86-64)
+;;; x86-64 no longer leaves a stray 0xFF..FFF word in the heap.
+;;; That bit pattern came from signed integer multiplication where the final result
+;;; was a bignum having 1 payload word, but the intermediate result was a bignum
+;;; whose trailing word was all 1s. Being a redundant copy of the sign bit from the
+;;; prior word, the bignum gets shortened. Only arm64 overallocates the bignum now.
+#+arm64
 (let ((product (manymul 1)))
   (sb-sys:with-pinned-objects (product)
     (let ((word (sb-sys:sap-ref-word

tests/x86-64-codegen.impure.lisp

@@ -1324,3 +1324,58 @@
               (declare (dynamic-extent copy))
               (values (func copy)))))))
     (assert (not vops-with-barrier))))
+
+;;; word-sized add, subtract, multiply vops which yield either a fixnum
+;;; or bignum where the bignum can have 1, 2, or 3 bigdigits.
+(defparameter unsigned-word-test-inputs
+  (loop for i from 0 by (ash 1 56) repeat 256 collect i))
+
+(defparameter signed-word-test-inputs
+  (loop for word in unsigned-word-test-inputs
+        collect (let ((b (sb-bignum:%allocate-bignum 1)))
+                  (setf (sb-bignum:%bignum-ref b 0) word)
+                  (sb-bignum::%normalize-bignum b 1))))
+
+(defun check-result (fun x y actual)
+  (let ((expect (funcall fun x y)))
+    (unless (eql actual expect)
+      (when (typep expect 'bignum)
+        (sb-vm:hexdump expect)
+        (terpri)
+        (sb-vm:hexdump actual))
+      (error "Failure @ ~X ~A ~X, expect ~D (~A) got ~D~%"
+             x fun y expect
+             (typecase expect
+               (fixnum 'fixnum)
+               (bignum (format nil "~d-word bignum"
+                               (sb-bignum:%bignum-length expect))))
+             actual))))
+
+(macrolet ((test-op (op)
+             `(progn
+                (format t "~&Testing ~A~%" ',op)
+                (dolist (x signed-word-test-inputs)
+                  (dolist (y signed-word-test-inputs)
+                    (check-result
+                     ',op x y
+                     (,op (the sb-vm:signed-word x) (the sb-vm:signed-word y))))))))
+  (defun test-signed ()
+    (test-op +)
+    (test-op -)
+    (test-op *)))
+
+(macrolet ((test-op (op)
+             `(progn
+                (format t "~&Testing ~A~%" ',op)
+                (dolist (x unsigned-word-test-inputs)
+                  (dolist (y unsigned-word-test-inputs)
+                    (check-result
+                     ',op x y
+                     (,op (the sb-vm:word x) (the sb-vm:word y))))))))
+  (defun test-unsigned ()
+    (test-op +)
+    (test-op -)
+    (test-op *)))
+
+(with-test (:name :signed-vops) (test-signed))
+(with-test (:name :unsigned-vops) (test-unsigned))