From 0c802a9a98aa5d78ced8bfc584803960b99090d2 Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Sun, 5 Mar 2023 23:30:23 -0500 Subject: [PATCH] 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 | 75 ++++++++++++++ src/assembly/x86-64/support.lisp | 11 +++ src/compiler/x86-64/arith.lisp | 165 +++++++++++++++++-------------- tests/heapwalk.impure.lisp | 7 +- tests/x86-64-codegen.impure.lisp | 55 +++++++++++ 5 files changed, 238 insertions(+), 75 deletions(-) diff --git a/src/assembly/x86-64/alloc.lisp b/src/assembly/x86-64/alloc.lisp index ab83b5212..6b9ecea1f 100644 --- a/src/assembly/x86-64/alloc.lisp +++ b/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)) diff --git a/src/assembly/x86-64/support.lisp b/src/assembly/x86-64/support.lisp index 18ec222ab..15f6c42df 100644 --- a/src/assembly/x86-64/support.lisp +++ b/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 diff --git a/src/compiler/x86-64/arith.lisp b/src/compiler/x86-64/arith.lisp index 822fc3ebd..c42f4bde3 100644 --- a/src/compiler/x86-64/arith.lisp +++ b/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 () diff --git a/tests/heapwalk.impure.lisp b/tests/heapwalk.impure.lisp index 7497cde32..950dc9ec1 100644 --- a/tests/heapwalk.impure.lisp +++ b/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 diff --git a/tests/x86-64-codegen.impure.lisp b/tests/x86-64-codegen.impure.lisp index 5086db964..c07340d8e 100644 --- a/tests/x86-64-codegen.impure.lisp +++ b/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))