Re: master: Fix immediate construction on loongarch, riscv
Charles Zhang via Sbcl-commits <[email protected]> Sun, 22 Feb 2026 10:27:11 +0000 (UTC)
| Newsgroups | gmane.lisp.steel-bank.cvs,gmane.lisp.steel-bank.devel |
|---|---|
| Message-ID | <[email protected]> |
Just a note: If a temp register is allocated anyway, the generic case can just be done by loading the high 32 bits into the temp register, 32 bits into the target register, and adding. On Sunday, February 22, 2026, 3:59 AM, stassats via Sbcl-commits <[email protected]> wrote: The branch "master" has been updated in SBCL: via fcc91d51a57bc79921d0bbe4ff7b4f2abc372317 (commit) from 5bf2decc30b259ac8dfb3ac1d052fd90e14a4e84 (commit) - Log ----------------------------------------------------------------- commit fcc91d51a57bc79921d0bbe4ff7b4f2abc372317 Author: Stas Boukarev <[email protected]> Date: Sun Feb 22 03:26:59 2026 +0300 Fix immediate construction on loongarch, riscv Where large immediates are constructed by adding and shifting left. Intermediate values might not be properly tagged for a descriptor register. --- src/assembly/riscv/assem-rtns.lisp | 4 +- src/compiler/loongarch64/insts.lisp | 90 +++++++++++++++++++++---------------- src/compiler/riscv/insts.lisp | 87 +++++++++++++++++++---------------- src/compiler/riscv/vm.lisp | 9 ++-- 4 files changed, 109 insertions(+), 81 deletions(-) diff --git a/src/assembly/riscv/assem-rtns.lisp b/src/assembly/riscv/assem-rtns.lisp index f61171d1e..5a1b023b2 100644 --- a/src/assembly/riscv/assem-rtns.lisp +++ b/src/assembly/riscv/assem-rtns.lisp @@ -266,7 +266,7 @@ ;; Don't want these to overlap with C args. (:temp pa-temp non-descriptor-reg nl6-offset) - (:temp temp non-descriptor-reg nl7-offset)) + (:temp temp non-descriptor-reg tmp-offset)) (save-c-registers) (initialize-boxed-regs (list function arg-ptr nargs #+sb-thread tls-ptr)) @@ -313,7 +313,7 @@ (:temp value0-pass (any-reg) (result-reg-offset 0)) (:temp value1-pass (any-reg) (result-reg-offset 1)) (:temp pa-temp (any-reg) nl6-offset) - (:temp temp (any-reg) nl7-offset)) + (:temp temp (unsigned-reg) tmp-offset)) ;; The C stack frame and argument registers should have already been ;; set up in Lisp. diff --git a/src/compiler/loongarch64/insts.lisp b/src/compiler/loongarch64/insts.lisp index b74cc318d..df4f1c44c 100644 --- a/src/compiler/loongarch64/insts.lisp +++ b/src/compiler/loongarch64/insts.lisp @@ -783,10 +783,11 @@ (u-and-i-inst-immediate immediate) (cond ((zerop hi) (inst addi.d rd zero-tn immediate)) + ((zerop lo) + (inst lu12i.w rd hi)) (t - (inst lu12i.w rd hi) - (unless (zerop lo) - (inst addi.d rd rd lo)))))) + (inst lu12i.w t7-tn hi) + (inst addi.d rd t7-tn lo))))) ;;;; li should optimization by lu32i, lu52i (defun %li (reg value) @@ -799,63 +800,76 @@ (integer-length (integer-length value)) (2^k (ash 1 integer-length)) (2^.k-1 (ash 1 (1- integer-length))) - (complement (mod (lognot value) (ash 1 64)))) + (complement (mod (lognot value) (ash 1 64))) + ;; Intermediate unboxed values might be inappropriate for a + ;; boxed target register + (tmp t7-tn)) (cond ((zerop (logand (1+ value) value)) ;; Common special case: the immediate is of the form #xfff... - (inst addi.d reg zero-tn -1) - (unless (= integer-length 64) - (inst srli.d reg reg (- 64 integer-length)))) + (inst addi.d tmp zero-tn -1) + (aver (/= integer-length 64)) + (inst srli.d reg tmp (- 64 integer-length))) ((let ((delta (- 2^k value))) (and (typep (ash delta (- 64 integer-length)) 'short-immediate) (logand delta (1- delta)))) ;; Common special case: the immediate is of the form ;; #x00fff...00, where there are a small number of ;; zeroes at the end. - (inst addi.d reg zero-tn (ash (- value 2^k) (- 64 integer-length))) - (inst srli.d reg reg (- 64 integer-length))) + (inst addi.d tmp zero-tn (ash (- value 2^k) (- 64 integer-length))) + (inst srli.d reg tmp (- 64 integer-length))) ((zerop (logand complement (1+ complement))) ;; #xfffffff...00000 - (inst addi.d reg zero-tn -1) - (inst slli.d reg reg (integer-length complement))) + (inst addi.d tmp zero-tn -1) + (inst slli.d reg tmp (integer-length complement))) ((typep (- value 2^k) 'short-immediate) ;; Common special case: loading an immediate which is a ;; signed 12 bit constant away from a power of 2. (cond ((= integer-length 64) (inst addi.d reg zero-tn (- value 2^k))) (t - (inst addi.d reg zero-tn 1) - (inst slli.d reg reg integer-length) - (inst addi.d reg reg (- value 2^k))))) + (inst addi.d tmp zero-tn 1) + (inst slli.d tmp tmp integer-length) + (inst addi.d reg tmp (- value 2^k))))) ((typep (- value 2^.k-1) 'short-immediate) ;; Common special case: loading an immediate which is a ;; signed 12 bit constant away from a power of 2. - (inst addi.d reg zero-tn 1) - (inst slli.d reg reg (1- integer-length)) - (unless (= value 2^.k-1) - (inst addi.d reg reg (- value 2^.k-1)))) + (inst addi.d tmp zero-tn 1) + (cond ((= value 2^.k-1) + (inst slli.d reg tmp (1- integer-length))) + (t + (inst slli.d tmp tmp (1- integer-length)) + (inst addi.d reg tmp (- value 2^.k-1))))) (t ;; The "generic" case. ;; Load in the first 31 non zero most significant bits. - (let ((chunk (ldb (byte 12 (- integer-length 31)) value))) - (inst lu12i.w reg (ldb (byte 20 (- integer-length 19)) value)) - (cond ((= (1- (ash 1 12)) chunk) - (inst addi.d reg reg (1- (ash 1 11))) - (inst addi.d reg reg (1- (ash 1 11))) - (inst addi.d reg reg 1)) - ((logbitp 11 chunk) - (inst addi.d reg reg (1- (ash 1 11))) - (inst addi.d reg reg (- chunk (1- (ash 1 11))))) - (t - (inst addi.d reg reg chunk)))) - ;; Now we need to load in the rest of the bits properly, in - ;; chunks of 11 to avoid sign extension. - (do ((i (- integer-length 31) (- i 11))) - ((< i 11) - (inst slli.d reg reg i) - (unless (zerop (ldb (byte i 0) value)) - (inst addi.d reg reg (ldb (byte i 0) value)))) - (inst slli.d reg reg 11) - (inst addi.d reg reg (ldb (byte 11 (- i 11)) value))))))) + (let ((chunk (ldb (byte 12 (- integer-length 31)) value)) + instructions) + (flet ((add-inst (m d o1 o2) + ;; Gotta know which instruction is the last one + ;; to put REG as its destination + (push (list m d o1 o2) instructions))) + (inst lu12i.w tmp (ldb (byte 20 (- integer-length 19)) value)) + (cond ((= (1- (ash 1 12)) chunk) + (inst addi.d tmp tmp (1- (ash 1 11))) + (inst addi.d tmp tmp (1- (ash 1 11))) + (add-inst 'addi.d tmp tmp 1)) + ((logbitp 11 chunk) + (inst addi.d tmp tmp (1- (ash 1 11))) + (add-inst 'addi.d tmp tmp (- chunk (1- (ash 1 11))))) + (t + (add-inst 'addi.d tmp tmp chunk))) + ;; Now we need to load in the rest of the bits properly, in + ;; chunks of 11 to avoid sign extension. + (do ((i (- integer-length 31) (- i 11))) + ((< i 11) + (add-inst 'slli.d tmp tmp i) + (unless (zerop (ldb (byte i 0) value)) + (add-inst 'addi.d tmp tmp (ldb (byte i 0) value)))) + (add-inst 'slli.d tmp tmp 11) + (add-inst 'addi.d tmp tmp (ldb (byte 11 (- i 11)) value))) + (setf (second (car instructions)) reg) + (loop for (m d o1 o2) in (reverse instructions) + do (inst* m d o1 o2)))))))) (fixup (inst lu12i.w reg value) (inst addi.d reg reg value)))) diff --git a/src/compiler/riscv/insts.lisp b/src/compiler/riscv/insts.lisp index 04ff8098c..e7135c811 100644 --- a/src/compiler/riscv/insts.lisp +++ b/src/compiler/riscv/insts.lisp @@ -19,7 +19,7 @@ sb-vm::registers sb-vm::float-registers sb-vm::zero sb-vm::zero-offset - sb-vm::lip-tn sb-vm::zero-tn + sb-vm::lip-tn sb-vm::zero-tn sb-vm::tmp-tn sb-vm::code-tn sb-vm::tn-byte-offset ;; Types @@ -441,10 +441,11 @@ (u-and-i-inst-immediate immediate) (cond ((zerop hi) (inst addi rd zero-tn immediate)) + ((zerop lo) + (inst lui rd hi)) (t - (inst lui rd hi) - (unless (zerop lo) - (inst addi rd rd lo)))))) + (inst lui tmp-tn hi) + (inst addi rd tmp-tn lo))))) (defun %li (reg value) (etypecase value @@ -457,63 +458,73 @@ (integer-length (integer-length value)) (2^k (ash 1 integer-length)) (2^.k-1 (ash 1 (1- integer-length))) - (complement (mod (lognot value) (ash 1 64)))) + (complement (mod (lognot value) (ash 1 64))) + (tmp tmp-tn)) (cond ((zerop (logand (1+ value) value)) ;; Common special case: the immediate is of the form #xfff... (inst addi reg zero-tn -1) - (unless (= integer-length 64) - (inst srli reg reg (- 64 integer-length)))) + (inst srli reg reg (- 64 integer-length))) ((let ((delta (- 2^k value))) (and (typep (ash delta (- 64 integer-length)) 'short-immediate) (logand delta (1- delta)))) ;; Common special case: the immediate is of the form ;; #x00fff...00, where there are a small number of ;; zeroes at the end. - (inst addi reg zero-tn (ash (- value 2^k) (- 64 integer-length))) - (inst srli reg reg (- 64 integer-length))) + (inst addi tmp zero-tn (ash (- value 2^k) (- 64 integer-length))) + (inst srli reg tmp (- 64 integer-length))) ((zerop (logand complement (1+ complement))) ;; #xfffffff...00000 - (inst addi reg zero-tn -1) - (inst slli reg reg (integer-length complement))) + (inst addi tmp zero-tn -1) + (inst slli reg tmp (integer-length complement))) ((typep (- value 2^k) 'short-immediate) ;; Common special case: loading an immediate which is a ;; signed 12 bit constant away from a power of 2. (cond ((= integer-length 64) (inst addi reg zero-tn (- value 2^k))) (t - (inst addi reg zero-tn 1) - (inst slli reg reg integer-length) - (inst addi reg reg (- value 2^k))))) + (inst addi tmp zero-tn 1) + (inst slli tmp tmp integer-length) + (inst addi reg tmp (- value 2^k))))) ((typep (- value 2^.k-1) 'short-immediate) ;; Common special case: loading an immediate which is a ;; signed 12 bit constant away from a power of 2. - (inst addi reg zero-tn 1) - (inst slli reg reg (1- integer-length)) - (unless (= value 2^.k-1) - (inst addi reg reg (- value 2^.k-1)))) + (inst addi tmp zero-tn 1) + (cond ((= value 2^.k-1) + (inst slli reg tmp (1- integer-length))) + (t + (inst slli tmp tmp (1- integer-length)) + (inst addi reg tmp (- value 2^.k-1))))) (t ;; The "generic" case. ;; Load in the first 31 non zero most significant bits. - (let ((chunk (ldb (byte 12 (- integer-length 31)) value))) - (inst lui reg (ldb (byte 20 (- integer-length 19)) value)) - (cond ((= (1- (ash 1 12)) chunk) - (inst addi reg reg (1- (ash 1 11))) - (inst addi reg reg (1- (ash 1 11))) - (inst addi reg reg 1)) - ((logbitp 11 chunk) - (inst addi reg reg (1- (ash 1 11))) - (inst addi reg reg (- chunk (1- (ash 1 11))))) - (t - (inst addi reg reg chunk)))) - ;; Now we need to load in the rest of the bits properly, in - ;; chunks of 11 to avoid sign extension. - (do ((i (- integer-length 31) (- i 11))) - ((< i 11) - (inst slli reg reg i) - (unless (zerop (ldb (byte i 0) value)) - (inst addi reg reg (ldb (byte i 0) value)))) - (inst slli reg reg 11) - (inst addi reg reg (ldb (byte 11 (- i 11)) value))))))) + (let ((chunk (ldb (byte 12 (- integer-length 31)) value)) + instructions) + (flet ((add-inst (m d o1 o2) + ;; Gotta know which instruction is the last one + ;; to put REG as its destination + (push (list m d o1 o2) instructions))) + (inst lui tmp (ldb (byte 20 (- integer-length 19)) value)) + (cond ((= (1- (ash 1 12)) chunk) + (inst addi tmp tmp (1- (ash 1 11))) + (inst addi tmp tmp (1- (ash 1 11))) + (add-inst 'addi tmp tmp 1)) + ((logbitp 11 chunk) + (inst addi tmp tmp (1- (ash 1 11))) + (add-inst 'addi tmp tmp (- chunk (1- (ash 1 11))))) + (t + (add-inst 'addi tmp tmp chunk))) + ;; Now we need to load in the rest of the bits properly, in + ;; chunks of 11 to avoid sign extension. + (do ((i (- integer-length 31) (- i 11))) + ((< i 11) + (add-inst 'slli tmp tmp i) + (unless (zerop (ldb (byte i 0) value)) + (add-inst 'addi tmp tmp (ldb (byte i 0) value)))) + (add-inst 'slli tmp tmp 11) + (add-inst 'addi tmp tmp (ldb (byte 11 (- i 11)) value))) + (setf (second (car instructions)) reg) + (loop for (m d o1 o2) in (reverse instructions) + do (inst* m d o1 o2)))))))) (fixup (inst lui reg value) (inst addi reg reg value)))) diff --git a/src/compiler/riscv/vm.lisp b/src/compiler/riscv/vm.lisp index c0a58f0ae..3950e56ec 100644 --- a/src/compiler/riscv/vm.lisp +++ b/src/compiler/riscv/vm.lisp @@ -65,7 +65,8 @@ (defreg l0 22) ; s6 (defreg nl6 23) ; s7 (defreg l1 24) ; s8 - (defreg nl7 25) ; s9 + ;; A register needed to load constants into descriptor-regs + (defreg tmp 25) ; s9 (defreg #-sb-thread l2 #+sb-thread thread 26) ; s10 (defreg cfunc 27) ; s11 @@ -74,7 +75,7 @@ (defreg code 30) ; t5 (defreg nargs 31) ; t6 - (defregset non-descriptor-regs nl0 nl1 nl2 ra nl3 nl4 nl5 nl6 nl7 nargs nfp cfunc) + (defregset non-descriptor-regs nl0 nl1 nl2 ra nl3 nl4 nl5 nl6 nargs nfp cfunc) (defregset descriptor-regs a0 a1 a2 a3 a4 a5 l0 l1 #-sb-thread l2 ocfp lexenv) (defregset reserve-descriptor-regs lexenv) (defregset reserve-non-descriptor-regs cfunc) @@ -210,7 +211,9 @@ (defregtn ocfp any-reg) (defregtn nfp any-reg) - (defregtn ra any-reg)) + (defregtn ra any-reg) + + (defregtn tmp unsigned-reg)) ;;; If VALUE can be represented as an immediate constant, then return the ;;; appropriate SC number, otherwise return NIL. ----------------------------------------------------------------------- hooks/post-receive -- SBCL _______________________________________________ Sbcl-commits mailing list [email protected] https://lists.sourceforge.net/lists/listinfo/sbcl-commits _______________________________________________ Sbcl-commits mailing list [email protected] https://lists.sourceforge.net/lists/listinfo/sbcl-commits