From 4ab4654f688ba973e2440f8f5c71a4469e91c74a Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Tue, 1 Sep 2026 21:54:48 +0000 Subject: [PATCH] arm64: implement tls-based-mv-return Authored by Antigravity --- build-all-cores.sh | 2 +- src/assembly/arm64/assem-rtns.lisp | 218 ++++++++++++++++++++++++++++- src/compiler/arm64/call.lisp | 125 ++++++++++++++++- src/compiler/arm64/macros.lisp | 5 + src/runtime/arm64-assem.S | 2 + 5 files changed, 343 insertions(+), 9 deletions(-) diff --git a/build-all-cores.sh b/build-all-cores.sh index f1adc88f8..e169cad42 100755 --- a/build-all-cores.sh +++ b/build-all-cores.sh @@ -32,7 +32,7 @@ ;;; This list is: arch-name and ((configuation-name feature ...) ...) (defparameter *all-configurations* '(("arm" ("arm" :little-endian :largefile)) - ("arm64" ("arm64" :little-endian :sb-thread) + ("arm64" ("arm64" :little-endian :sb-thread :tls-based-mv-return) ("arm64+simd" :little-endian :sb-thread :sb-simd-pack) ("arm64-darwin" :darwin :bsd :unix :mach-o :little-endian :sb-thread :darwin-jit) ("arm64-reloc" :little-endian :sb-thread :relocatable-static-space :immobile-space) diff --git a/src/assembly/arm64/assem-rtns.lisp b/src/assembly/arm64/assem-rtns.lisp index 141cf1d73..80c5c9980 100644 --- a/src/assembly/arm64/assem-rtns.lisp +++ b/src/assembly/arm64/assem-rtns.lisp @@ -2,7 +2,7 @@ ;;;; Return-multiple with other than one value -#+sb-assembling ;; we don't want a vop for this one. +#+(and (not tls-based-mv-return) sb-assembling) ;; we don't want a vop for this one. (define-assembly-routine (return-multiple (:return-style :none)) @@ -68,6 +68,7 @@ ;; Return. (lisp-return lra :multiple-values t)) +#-tls-based-mv-return (define-assembly-routine (return-values-list (:return-style :none) @@ -165,6 +166,221 @@ FOUR-VALUES (inst add csp-tn ocfp-tn (lsl count (- word-shift n-fixnum-tag-bits))) (lisp-return lr :multiple-values)))) + +#+tls-based-mv-return +(progn +(defmacro check-and-save-mv-count (count) + `(progn + (inst cmp ,count (fixnumize multiple-values-limit)) + (inst b :hs (assemble (:elsewhere) + TOO-MANY-VALUES ; could make this continuable (for no good reason) + (error-call nil 'too-many-return-values-error + (make-random-tn (sc-or-lose 'any-reg) (tn-offset ,count))) + (progn TOO-MANY-VALUES))) + (inst strb ,count (thread-mv-count)))) + +#+sb-assembling ;; We don't want a vop for this one. +(define-assembly-routine + (return-multiple + (:return-style :none)) + + ;; These are really arguments. + ((:temp nvals any-reg nargs-offset) + (:temp vals any-reg nl1-offset) + (:temp lra non-descriptor-reg lr-offset) + + ;; These are just needed to facilitate the transfer + (:temp count any-reg nl3-offset) + (:temp src any-reg nl4-offset) + (:temp dst descriptor-reg r4-offset) + (:temp temp descriptor-reg r5-offset) + + ;; These are needed so we can get at the register args. + (:temp r0 descriptor-reg r0-offset) + (:temp r1 descriptor-reg r1-offset) + (:temp r2 descriptor-reg r2-offset) + (:temp r3 descriptor-reg r3-offset)) + + ;; Pick off the cases where everything fits in register args. + (inst cmp nvals (fixnumize 1)) + (inst b :eq ONE-VALUE) + (inst b :lt ZERO-VALUES) + (inst cmp nvals (fixnumize 2)) + (inst b :eq TWO-VALUES) + (inst cmp nvals (fixnumize 3)) + (inst b :eq THREE-VALUES) + (inst cmp nvals (fixnumize 4)) + (inst b :eq FOUR-VALUES) + + ;; Values > 4: + (check-and-save-mv-count nvals) + ;; Load register values r0, r1, r2, r3 + (inst ldp r0 r1 (@ vals)) + (loadw r2 vals 2) + (loadw r3 vals 3) + + ;; Copy remaining values to thread-mv-return-values + (inst add src vals (* 4 n-word-bytes)) + (inst add dst thread-tn (add-sub-immediate (* thread-mv-return-values-slot n-word-bytes))) + (inst sub count nvals (fixnumize 4)) + + LOOP + (inst subs count count (fixnumize 1)) + (inst ldr temp (@ src n-word-bytes :post-index)) + (inst str temp (@ dst n-word-bytes :post-index)) + (inst b :gt LOOP) + + (move csp-tn cfp-tn) + (lisp-return lra :multiple-values t) + + ;; Handle the register arg cases. + ZERO-VALUES + (move r0 null-tn) + (move r1 null-tn) + (move r2 null-tn) + (move r3 null-tn) + (move csp-tn cfp-tn) + (lisp-return lra :multiple-values t) + + ONE-VALUE + (loadw r0 vals 0) + (move csp-tn cfp-tn) + (lisp-return lra :single-value t) + + TWO-VALUES + (inst ldp r0 r1 (@ vals)) + (move r2 null-tn) + (move r3 null-tn) + (move csp-tn cfp-tn) + (lisp-return lra :multiple-values t) + + THREE-VALUES + (inst ldp r0 r1 (@ vals)) + (loadw r2 vals 2) + (move r3 null-tn) + (move csp-tn cfp-tn) + (lisp-return lra :multiple-values t) + + FOUR-VALUES + (inst ldp r0 r1 (@ vals)) + (loadw r2 vals 2) + (loadw r3 vals 3) + (move csp-tn cfp-tn) + (lisp-return lra :multiple-values t)) + +(define-assembly-routine + (return-values-list + (:return-style :none) + (:vop-var vop) + (:vop-prefix + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst add nsp-tn cur-nfp (add-sub-immediate + (bytes-needed-for-non-descriptor-stack-frame))))))) + + ;; These four are really arguments. + ((:arg list descriptor-reg r5-offset) + (:temp count any-reg nargs-offset) + (:temp temp descriptor-reg r6-offset) + (:temp ndescr non-descriptor-reg nl0-offset) + (:temp src non-descriptor-reg nl1-offset) + + (:temp lr non-descriptor-reg lr-offset) + (:temp r0 descriptor-reg r0-offset) + (:temp r1 descriptor-reg r1-offset) + (:temp r2 descriptor-reg r2-offset) + (:temp r3 descriptor-reg r3-offset)) + (flet ((check (label) + (assemble () + (%test-lowtag list temp skip nil list-pointer-lowtag) + (cerror-call nil 'bogus-arg-to-values-list-error list) + (inst b label) + skip))) + (assemble () + (move ocfp-tn cfp-tn) + (loadw-pair cfp-tn ocfp-save-offset lr lra-save-offset cfp-tn) + (%test-lowtag list ndescr ZERO-VALUES-ERROR t list-pointer-lowtag) + (inst cmp list null-tn) + (inst b :eq ZERO-VALUES) + + (loadw r0 list cons-car-slot list-pointer-lowtag) + (loadw list list cons-cdr-slot list-pointer-lowtag) + (inst cmp list null-tn) + (inst b :ne CONTINUE) + + ONE-VALUE + (move csp-tn ocfp-tn) + (lisp-return lr :single-value) + CONTINUE + (check ONE-VALUE) + + (inst mov count (fixnumize 2)) + (loadw r1 list cons-car-slot list-pointer-lowtag) + (loadw list list cons-cdr-slot list-pointer-lowtag) + (inst cmp list null-tn) + (inst b :eq TWO-VALUES) + (check TWO-VALUES) + + (inst mov count (fixnumize 3)) + (loadw r2 list cons-car-slot list-pointer-lowtag) + (loadw list list cons-cdr-slot list-pointer-lowtag) + (inst cmp list null-tn) + (inst b :eq THREE-VALUES) + (check THREE-VALUES) + + (inst mov count (fixnumize 4)) + (loadw r3 list cons-car-slot list-pointer-lowtag) + (loadw list list cons-cdr-slot list-pointer-lowtag) + (inst cmp list null-tn) + (inst b :eq FOUR-VALUES) + (check FOUR-VALUES) + + ;; Values > 4: + ;; Store values 5, 6, ... onto the stack starting at ocfp-tn. + (move csp-tn ocfp-tn) + LOOP + (inst add count count (fixnumize 1)) + (loadw temp list cons-car-slot list-pointer-lowtag) + (loadw list list cons-cdr-slot list-pointer-lowtag) + (inst str temp (@ csp-tn n-word-bytes :post-index)) + (check DONE) + (inst cmp list null-tn) + (inst b :ne LOOP) + + DONE + (check-and-save-mv-count count) + + ;; Copy remaining values from stack into thread-mv-return-values + (inst add list thread-tn (add-sub-immediate (* thread-mv-return-values-slot n-word-bytes))) + (inst sub ndescr count (fixnumize 4)) ; number of extra values in TLS + (move src ocfp-tn) + COPY + (inst subs ndescr ndescr (fixnumize 1)) + (inst ldr temp (@ src n-word-bytes :post-index)) + (inst str temp (@ list n-word-bytes :post-index)) + (inst b :gt COPY) + + (move csp-tn ocfp-tn) + (lisp-return lr :multiple-values) + + ZERO-VALUES-ERROR + (cerror-call nil 'bogus-arg-to-values-list-error list) + ZERO-VALUES + (inst mov count 0) + (inst mov r0 null-tn) + (inst mov r1 null-tn) + + TWO-VALUES + (inst mov r2 null-tn) + (inst mov r3 null-tn) + + THREE-VALUES + (inst mov r3 null-tn) + + FOUR-VALUES + (move csp-tn ocfp-tn) + (lisp-return lr :multiple-values)))) +) ; end #+tls-based-mv-return ;;;; tail-call-variable. (defun prepare-for-tail-call-variable (nargs args count dest temp r0 r1 r2 r3) diff --git a/src/compiler/arm64/call.lisp b/src/compiler/arm64/call.lisp index 4256d0245..1b4d6e752 100644 --- a/src/compiler/arm64/call.lisp +++ b/src/compiler/arm64/call.lisp @@ -255,13 +255,14 @@ (type-single-value-p type))) (cond ((or (not trust) (values-type-may-be-single-value-p type)) - (inst csel csp-tn ocfp-tn csp-tn :eq) + #-tls-based-mv-return (inst csel csp-tn ocfp-tn csp-tn :eq) (unless trust (inst mov tmp-tn (fixnumize 1)) (inst csel nargs-tn tmp-tn nargs-tn :ne) (check-nargs))) ((eq type *empty-type*)) (t + #-tls-based-mv-return (inst mov csp-tn ocfp-tn)))) (macrolet ((map-stack-values (&body body) `(do ((i register-arg-count (1+ i)) @@ -294,7 +295,7 @@ (> min-values 1))) ((or (not trust) stack-targets-p) - (inst csel ocfp-tn csp-tn ocfp-tn :ne) + #-tls-based-mv-return (inst csel ocfp-tn csp-tn ocfp-tn :ne) (inst mov tmp-tn (fixnumize 1)) (inst csel nargs-tn tmp-tn nargs-tn :ne) (unless trust @@ -306,6 +307,15 @@ (incf decrement (fixnumize 1))) ((< i min-values) (incf decrement (fixnumize 1)) + #+tls-based-mv-return + (let ((slot (+ thread-mv-return-values-slot (- i register-arg-count)))) + (sc-case tn + (control-stack + (loadw move-temp thread-tn slot) + (store-stack-tn tn move-temp)) + (t + (loadw tn thread-tn slot)))) + #-tls-based-mv-return (sc-case tn (control-stack (let* ((next (and (< (1+ i) min-values) @@ -357,12 +367,16 @@ (when stack-targets-p (move dst null-tn)) (inst b :lt NONE) + #+tls-based-mv-return + (loadw dst thread-tn (+ thread-mv-return-values-slot + (- i register-arg-count))) + #-tls-based-mv-return (loadw dst ocfp-tn i) NONE (when (sc-is tn control-stack) (store-stack-tn tn dst)))))))) ;; Deallocate the callee stack frame. - (move csp-tn ocfp-tn))) + #-tls-based-mv-return (move csp-tn ocfp-tn))) DONE)))) (values)) @@ -386,6 +400,7 @@ ;;; results Start and Count (also, it's nice to be able to target them). (defun receive-unknown-values (node args nargs start count) (declare (type tn args nargs start count)) + #-tls-based-mv-return (let ((unused-count-p (eq (tn-kind count) :unused)) (unused-start-p (eq (tn-kind start) :unused)) (type (sb-c::node-derived-type node))) @@ -415,7 +430,59 @@ (move start args)) (unless unused-count-p (move count nargs)) - DONE)))) + DONE))) + #+tls-based-mv-return + (let ((unused-count-p (eq (tn-kind count) :unused)) + (unused-start-p (eq (tn-kind start) :unused)) + (type (sb-c::node-derived-type node)) + (variable-values (gen-label)) + (done (gen-label))) + (assemble () + (when (values-type-may-be-single-value-p type) + (inst b :eq variable-values) + (unless unused-start-p + (move start csp-tn)) + (inst str (first *register-arg-tns*) (@ csp-tn n-word-bytes :post-index)) + (unless unused-count-p + (inst mov count (fixnumize 1))) + (inst b done) + (emit-label variable-values)) + + ;; Multiple values case: + ;; Save current csp-tn into args (values-start) before allocating stack space + (move args csp-tn) + ;; Allocate stack space for nargs values + (inst add csp-tn csp-tn (lsl nargs (- word-shift n-fixnum-tag-bits))) + ;; Store register args onto stack at args + (inst stp (first *register-arg-tns*) (second *register-arg-tns*) (@ args)) + (inst stp (third *register-arg-tns*) (fourth *register-arg-tns*) (@ args (* 2 n-word-bytes))) + + ;; If > 4 values, copy thread-mv-return-values onto stack + (when (> (sb-kernel:values-type-max-value-count type) register-arg-count) + (let ((countdown tmp-tn) + (src (first *register-arg-tns*)) + (dst (second *register-arg-tns*)) + (scratch (third *register-arg-tns*)) + (copy-done (gen-label)) + (copy-loop (gen-label))) + (inst cmp nargs (fixnumize register-arg-count)) + (inst b :le copy-done) + (inst sub countdown nargs (fixnumize register-arg-count)) + (inst add src thread-tn (add-sub-immediate (* thread-mv-return-values-slot n-word-bytes))) + (inst add dst args (* register-arg-count n-word-bytes)) + (emit-label copy-loop) + (inst subs countdown countdown (fixnumize 1)) + (inst ldr scratch (@ src n-word-bytes :post-index)) + (inst str scratch (@ dst n-word-bytes :post-index)) + (inst b :gt copy-loop) + (emit-label copy-done))) + + (unless unused-start-p + (move start args)) + (unless unused-count-p + (move count nargs)) + (emit-label done))) + (values)) ;;; VOP that can be inherited by unknown values receivers. The main ;;; thing this handles is allocation of the result temporaries. @@ -1262,8 +1329,11 @@ (:args (old-fp) (return-pc) - (values :more t)) - (:ignore values old-fp return-pc) + (values :more t + #+tls-based-mv-return :scs + #+tls-based-mv-return (descriptor-reg any-reg control-stack constant immediate))) + #-tls-based-mv-return (:ignore values old-fp return-pc) + #+tls-based-mv-return (:ignore old-fp return-pc) (:info nvals) (:temporary (:sc descriptor-reg :offset r0-offset :from (:eval 0)) r0) (:temporary (:sc descriptor-reg :offset r1-offset :from (:eval 0)) r1) @@ -1271,6 +1341,7 @@ (:temporary (:sc descriptor-reg :offset r3-offset :from (:eval 0)) r3) (:temporary (:sc non-descriptor-reg :offset lr-offset) lr) (:temporary (:sc any-reg :offset nargs-offset) nargs) + #-tls-based-mv-return (:temporary (:sc any-reg :offset ocfp-offset) val-ptr) (:vop-var vop) (:generator 6 @@ -1279,6 +1350,7 @@ (when cur-nfp (inst add nsp-tn cur-nfp (add-sub-immediate (bytes-needed-for-non-descriptor-stack-frame))))) + #-tls-based-mv-return (cond ((= nvals 1) ;; Clear the control stack, and restore the frame pointer. (move csp-tn cfp-tn) @@ -1295,7 +1367,46 @@ (dolist (reg (subseq (list r0 r1 r2 r3) nvals)) (move reg null-tn))) ;; And away we go. - (lisp-return lr :multiple-values t))))) + (lisp-return lr :multiple-values t))) + #+tls-based-mv-return + (cond + ((= nvals 1) + (move csp-tn cfp-tn) + (lisp-return lr :single-value t)) + ((>= nvals multiple-values-limit) + (load-immediate-word nargs (fixnumize nvals)) + (error-call vop 'too-many-return-values-error nargs)) + (t + (load-immediate-word nargs (fixnumize nvals)) + (when (< nvals register-arg-count) + (dolist (reg (subseq (list r0 r1 r2 r3) nvals)) + (move reg null-tn))) + (when (> nvals register-arg-count) + (do ((tn-ref (do ((i register-arg-count (1- i)) ; skip over this many + (ref values (tn-ref-across ref))) + ((zerop i) ref)) + (tn-ref-across tn-ref)) + (slot 0 (1+ slot))) + ((null tn-ref)) + (let ((tn (tn-ref-tn tn-ref)) + (ea (@ thread-tn + (load-store-offset + (ash (+ thread-mv-return-values-slot slot) word-shift))))) + (sc-case tn + ((descriptor-reg any-reg) + (inst str tn ea)) + ((control-stack) + (load-stack-tn tmp-tn tn) + (inst str tmp-tn ea)) + ((constant) + (inst load-constant tmp-tn (tn-byte-offset tn)) + (inst str tmp-tn ea)) + ((immediate) + (load-immediate vop tn tmp-tn) + (inst str tmp-tn ea))))) + (inst strb nargs (thread-mv-count))) + (move csp-tn cfp-tn) + (lisp-return lr :multiple-values t))))) ;;; Do unknown-values return of an arbitrary number of values (passed ;;; on the stack.) We check for the common case of a single return diff --git a/src/compiler/arm64/macros.lisp b/src/compiler/arm64/macros.lisp index 7be2f5a9e..863d067d8 100644 --- a/src/compiler/arm64/macros.lisp +++ b/src/compiler/arm64/macros.lisp @@ -582,6 +582,11 @@ #-sb-thread `(store-symbol-value ,reg ,symbol)) +#+tls-based-mv-return +(defmacro thread-mv-count () + ;; This is byte index 1 of thread_state_word + '(@ thread-tn (1+ (ash thread-state-word-slot word-shift)))) + ;;; Load constants, stack-values, reusing when possible (defmacro maybe-load (tn &optional (temp 'temp)) (once-only ((tn tn)) diff --git a/src/runtime/arm64-assem.S b/src/runtime/arm64-assem.S index 8dd3a11ed..c59611331 100644 --- a/src/runtime/arm64-assem.S +++ b/src/runtime/arm64-assem.S @@ -269,8 +269,10 @@ Lno_args: ldr reg_LR, [reg_LEXENV, #CLOSURE_FUN_OFFSET] blr reg_LR +#ifndef LISP_FEATURE_TLS_BASED_MV_RETURN // Correct stack pointer for return processing. csel reg_CSP, reg_OCFP, reg_CSP, eq +#endif // Return value mov x0, reg_R0