arm64: implement tls-based-mv-return

Authored by Antigravity

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)

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)

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))
+   (values :more t
-  (:ignore values old-fp return-pc)
+           #+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,6 +1367,45 @@
              (dolist (reg (subseq (list r0 r1 r2 r3) nvals))
                (move reg null-tn)))
            ;; And away we go.
+           (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

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))

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