[PATCH 2/13] Add assembly support for loongarch64

From afc83ddb9d85fac8d7f4c384e457055908e454a4 Mon Sep 17 00:00:00 2001
From: ZiLong Wang <[email protected]>
Date: Sat, 17 Jan 2026 10:00:39 +0800
Subject: [PATCH 02/13] Add assembly support for loongarch

---
 src/assembly/loongarch64/alloc.lisp      |  58 +++++
 src/assembly/loongarch64/arith.lisp      |  12 +
 src/assembly/loongarch64/array.lisp      |  13 +
 src/assembly/loongarch64/assem-rtns.lisp | 313 +++++++++++++++++++++++
 src/assembly/loongarch64/support.lisp    |  43 ++++
 src/assembly/loongarch64/tramps.lisp     | 166 ++++++++++++
 6 files changed, 605 insertions(+)
 create mode 100644 src/assembly/loongarch64/alloc.lisp
 create mode 100644 src/assembly/loongarch64/arith.lisp
 create mode 100644 src/assembly/loongarch64/array.lisp
 create mode 100644 src/assembly/loongarch64/assem-rtns.lisp
 create mode 100644 src/assembly/loongarch64/support.lisp
 create mode 100644 src/assembly/loongarch64/tramps.lisp

diff --git a/src/assembly/loongarch64/alloc.lisp b/src/assembly/loongarch64/alloc.lisp
new file mode 100644
index 000000000..988d20701
--- /dev/null
+++ b/src/assembly/loongarch64/alloc.lisp
@@ -0,0 +1,58 @@
+;;;; allocating simple objects
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-VM")
+
+#+sb-thread
+(define-assembly-routine (alloc-tls-index
+                          (:translate ensure-symbol-tls-index)
+                          (:result-types positive-fixnum)
+                          (:policy :fast-safe))
+    ((:arg symbol (descriptor-reg) l0-offset)
+     (:temp free-tls-index (any-reg) l1-offset)
+     (:temp temp (non-descriptor-reg) nl1-offset)
+     (:res tls-index (unsigned-reg) nl0-offset))
+  (inst addi.d free-tls-index null-tn (+ (static-symbol-offset '*free-tls-index*)
+                                       (ash symbol-value-slot word-shift)
+                                       (- other-pointer-lowtag)))
+  (pseudo-atomic (temp)
+    ACQUIRE-LOCK
+    (inst li temp 1)
+    (inst slli.d temp temp (1- n-word-bits))
+    WITH-LOCK-BIT
+    (loadw tls-index free-tls-index)
+    ;; The MSB (i.e. sign) is the semaphore.
+    (inst blt tls-index zero-tn WITH-LOCK-BIT)
+    (inst amor_db.d temp temp free-tls-index)
+    (inst bne tls-index temp ACQUIRE-LOCK)
+
+    ;; With the spinlock now held, see if the symbol's tls-index has
+    ;; been set in the meantime.
+    (load-tls-index tls-index symbol)
+    (inst bne tls-index zero-tn RELEASE-LOCK)
+
+    ;; Allocate a new tls-index.
+    (move tls-index temp)
+    (loadw temp thread-base-tn thread-tls-size-slot)
+    (inst bgeu tls-index temp tls-full)
+
+    (store-tls-index tls-index symbol)
+    (inst addi.d temp tls-index n-word-bytes)
+
+    RELEASE-LOCK
+    ;; Update the free-tls-index and release the lock in one go.
+    (inst amswap_db.d zero-tn temp free-tls-index))
+  (inst jirl zero-tn lip-tn 0)
+  TLS-FULL
+  ;; Release the lock.
+  (storew tls-index free-tls-index)
+  (clear-pseudo-atomic-bit)
+  (error-call nil 'tls-exhausted-error))
diff --git a/src/assembly/loongarch64/arith.lisp b/src/assembly/loongarch64/arith.lisp
new file mode 100644
index 000000000..b11daee10
--- /dev/null
+++ b/src/assembly/loongarch64/arith.lisp
@@ -0,0 +1,12 @@
+;;;; simple cases for generic arithmetic
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-VM")
diff --git a/src/assembly/loongarch64/array.lisp b/src/assembly/loongarch64/array.lisp
new file mode 100644
index 000000000..3aa0aa223
--- /dev/null
+++ b/src/assembly/loongarch64/array.lisp
@@ -0,0 +1,13 @@
+;;;; various array operations that are too expensive (in space) to do
+;;;; inline
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-VM")
diff --git a/src/assembly/loongarch64/assem-rtns.lisp b/src/assembly/loongarch64/assem-rtns.lisp
new file mode 100644
index 000000000..53b1f167a
--- /dev/null
+++ b/src/assembly/loongarch64/assem-rtns.lisp
@@ -0,0 +1,313 @@
+;;;; the machine specific support routines needed by the file assembler
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-VM")
+
+;;;; Return-multiple with other than one value
+#+sb-assembling
+(define-assembly-routine
+    (return-multiple
+     (:return-style :none))
+    ((:temp nvals any-reg nargs-offset)
+     (:temp vals any-reg nl0-offset)
+     (:temp ocfp any-reg nl1-offset)
+     (:temp ra non-descriptor-reg ra-offset)
+
+     (:temp count any-reg nl2-offset)
+     (:temp dst any-reg nl3-offset)
+     (:temp temp descriptor-reg l0-offset)
+
+     (:temp a0 descriptor-reg a0-offset)
+     (:temp a1 descriptor-reg a1-offset))
+  ;; Note, because of the way the return-multiple vop is
+  ;; written, we can assume that we are never called
+  ;; with nvals == 1 and that a0 has already been
+  ;; loaded.
+  (inst subi count nvals (fixnumize 2))
+  (let ((defaulting-labels (loop repeat (- register-arg-count 1)
+                                 collect (gen-label)))
+        (loop (gen-label))
+        (default-a0-and-on (gen-label)))
+    (inst bge zero-tn nvals default-a0-and-on)
+    (loop for label in defaulting-labels
+          for an in (rest *register-arg-tns*)
+          for i from 1
+          do (progn
+               (unless (= i 1)
+                 (inst subi count count (fixnumize 1)))
+               (loadw an vals i)
+               (inst bge zero-tn count label)))
+    ;; Copy the remaining args to the top of the stack.
+    (inst addi.d vals vals (* register-arg-count n-word-bytes))
+    (inst addi.d dst cfp-tn (* register-arg-count n-word-bytes))
+
+    (emit-label loop)
+    (loadw temp vals)
+    (inst addi.d vals vals n-word-bytes)
+    (inst subi count count (fixnumize 1))
+    (storew temp dst)
+    (inst addi.d dst dst n-word-bytes)
+    (inst bne count zero-tn loop)
+
+    (inst j (first (last defaulting-labels)))
+
+    (emit-label default-a0-and-on)
+    (move a0 null-tn)
+    (move a1 null-tn)
+    (loop for defaulting-label in defaulting-labels
+          for an in (rest (rest *register-arg-tns*))
+          do (progn
+               (emit-label defaulting-label)
+               (move an null-tn)))
+    (emit-label (first (last defaulting-labels))))
+
+  ;; Clear the stack.
+  (move ocfp-tn cfp-tn)
+  (move cfp-tn ocfp)
+  (with-fixnum-as-word-index (nvals temp)
+    (inst add.d csp-tn ocfp-tn nvals))
+  (inst jirl zero-tn ra 0))
+
+#+sb-assembling
+(define-assembly-routine
+    (tail-call-variable
+     (:return-style :none))
+    ((:temp args any-reg nl0-offset)
+     (:temp lexenv descriptor-reg lexenv-offset)
+     (:temp nargs any-reg nargs-offset)
+     (:temp src any-reg nl1-offset)
+     (:temp dst any-reg nl2-offset)
+     (:temp count any-reg nl3-offset)
+     (:temp temp descriptor-reg l0-offset)
+     (:temp tmp descriptor-reg t7-offset)
+     (:temp function descriptor-reg l0-offset))
+  (inst sub.d nargs csp-tn args)
+  (loop for an in *register-arg-tns*
+        for i from 0
+        do (loadw an args i))
+  (inst subi count nargs (* register-arg-count n-word-bytes))
+  (inst addi.d src args (* register-arg-count n-word-bytes))
+  (inst bge zero-tn count done)
+  (inst addi.d dst cfp-tn (* register-arg-count n-word-bytes))
+  
+  LOOP
+  (loadw temp src)
+  (inst addi.d src src n-word-bytes)
+  (storew temp dst)
+  (inst subi count count n-word-bytes)
+  (inst addi.d dst dst n-word-bytes)
+  (inst blt zero-tn count LOOP)
+  
+  DONE
+  (with-word-index-as-fixnum (nargs nargs))
+  (loadw function lexenv closure-fun-slot fun-pointer-lowtag)
+  
+  (inst addi.d tmp function (- fun-pointer-lowtag))
+  (inst jirl   zero-tn tmp (ash simple-fun-insts-offset word-shift)))
+
+;;;; Non-local exit noise.
+(define-assembly-routine (throw
+                          (:return-style :full-call-no-return)
+                          (:save-p :compute-only))
+    ((:arg target (descriptor-reg any-reg) a0-offset)
+     (:arg start (descriptor-reg any-reg) ocfp-offset)
+     (:arg count (descriptor-reg any-reg) nargs-offset) 
+     (:temp catch any-reg a1-offset) 
+     (:temp tag descriptor-reg a2-offset))
+  (declare (ignore start count))
+  (load-current-catch-block catch)
+  LOOP
+  (let ((error (generate-error-code nil 'unseen-throw-tag-error target)))
+    (inst beq catch zero-tn error))
+
+  (loadw tag catch catch-block-tag-slot)
+  (inst beq tag target EXIT)
+  (loadw catch catch catch-block-previous-catch-slot)
+  (inst j LOOP)
+
+  EXIT
+  (move target catch) 
+  (inst jal zero-tn (make-fixup 'unwind :assembly-routine)))
+
+(define-assembly-routine (unwind
+                          (:translate %unwind)
+                          (:policy :fast-safe)
+                          (:return-style :full-call-no-return)
+                          (:save-p :compute-only))
+    ((:arg block (descriptor-reg any-reg) a0-offset) 
+     (:arg start (descriptor-reg any-reg) ocfp-offset) 
+     (:arg count (descriptor-reg any-reg) nargs-offset)
+     (:temp cur-uwp any-reg nl0-offset)
+     (:temp temp any-reg nl1-offset)
+     (:temp target-uwp any-reg nl2-offset))
+  (declare (ignore start count))
+  (let ((error (generate-error-code nil 'invalid-unwind-error)))
+    (inst beq block zero-tn error))
+
+  (load-current-unwind-protect-block cur-uwp)
+  (loadw target-uwp block unwind-block-uwp-slot)
+  (inst bne cur-uwp target-uwp DO-UWP)
+  (move cur-uwp block)
+
+  DO-EXIT
+  (loadw cfp-tn cur-uwp unwind-block-cfp-slot)
+  (loadw code-tn cur-uwp unwind-block-code-slot)
+  (loadw temp cur-uwp unwind-block-entry-pc-slot)
+  (inst jirl zero-tn temp 0)
+
+  DO-UWP
+  (loadw target-uwp cur-uwp unwind-block-uwp-slot)
+  (store-current-unwind-protect-block target-uwp)
+  (inst j DO-EXIT))
+
+;;;; Some runtime routines.
+(let* ((n-saved-registers (length c-saved-registers))
+       (n-saved-float-registers (length c-saved-float-registers))
+       (framesize (+ (* n-word-bytes n-saved-registers)
+                     (* 8 n-saved-float-registers))))
+  (defun save-c-registers ()
+    (inst subi nsp-tn nsp-tn framesize)
+    (loop for offset from 0
+          for saved-offset in c-saved-registers
+          do (storew (make-reg-tn saved-offset) nsp-tn offset))
+    (loop for offset from (* n-word-bytes n-saved-registers) by 8
+          for saved-offset in c-saved-float-registers
+          do (inst fstore :double (make-reg-tn saved-offset) nsp-tn offset)))
+
+  (defun restore-c-registers ()
+    (loop for offset from 0
+          for saved-offset in c-saved-registers
+          do (loadw (make-reg-tn saved-offset) nsp-tn offset))
+    (loop for offset from (* n-word-bytes n-saved-registers) by 8
+          for saved-offset in c-saved-float-registers
+          do (inst fload :double (make-reg-tn saved-offset) nsp-tn offset))
+    (inst addi.d nsp-tn nsp-tn framesize)))
+
+(defun initialize-boxed-regs (&optional still-live)
+  (dolist (boxed-reg-offset boxed-regs)
+    (unless (member boxed-reg-offset still-live :key #'tn-offset)
+      (inst li (make-reg-tn boxed-reg-offset) 0)))
+  (inst li null-tn nil-value))
+
+(defun set-up-lisp-context (stack-pointer frame-pointer temp)
+  #+sb-thread
+  (declare (ignore temp))
+  ;; Initializing the allocation pointer is done already in
+  ;; coreparse.
+  #+sb-thread
+  (progn
+    (loadw stack-pointer thread-base-tn thread-control-stack-pointer-slot)
+    (loadw frame-pointer thread-base-tn thread-control-frame-pointer-slot)
+    (storew zero-tn thread-base-tn thread-ffcall-active-p-slot))
+  #-sb-thread
+  (progn
+    (load-foreign-symbol-value stack-pointer "current_control_stack_pointer" temp)
+    (load-foreign-symbol-value frame-pointer "current_control_frame_pointer" temp)
+    (store-foreign-symbol-value zero-tn "foreign_function_call_active" temp)))
+
+(defun save-lisp-context (stack-pointer frame-pointer temp)
+  #+sb-thread
+  (declare (ignore temp))
+  #+sb-thread
+  (progn
+    (storew stack-pointer thread-base-tn thread-control-stack-pointer-slot)
+    (storew frame-pointer thread-base-tn thread-control-frame-pointer-slot)
+    (storew null-tn thread-base-tn thread-ffcall-active-p-slot))
+  #-sb-thread
+  (progn
+    (store-foreign-symbol-value stack-pointer "current_control_stack_pointer" temp)
+    (store-foreign-symbol-value frame-pointer "current_control_frame_pointer" temp)
+    (store-foreign-symbol-value null-tn "foreign_function_call_active" temp)))
+
+(define-assembly-routine (call-into-lisp (:return-style :none))
+    ((:arg function (descriptor-reg any-reg) ca0-offset)
+     (:arg arg-ptr (descriptor-reg any-reg) ca1-offset)
+     (:arg nargs (any-reg) ca2-offset) 
+     #+sb-thread
+     (:arg tls-ptr (any-reg) ca3-offset) 
+     (:arg ra (any-reg) ra-offset) 
+     (:temp a0 descriptor-reg a0-offset)
+     (:temp value (descriptor-reg any-reg) ca0-offset)
+     (:temp fun (descriptor-reg) l0-offset)
+     (:temp pa-temp non-descriptor-reg nl4-offset)
+     (:temp temp non-descriptor-reg nl5-offset)
+     (:temp tmp non-descriptor-reg t7-offset))
+  (save-c-registers)
+  (initialize-boxed-regs (list function arg-ptr nargs #+sb-thread tls-ptr))
+  #+sb-thread
+  (move thread-base-tn tls-ptr)
+  (inst slli.d nargs-tn nargs n-fixnum-tag-bits)
+  
+  (pseudo-atomic (pa-temp)
+    (set-up-lisp-context csp-tn ocfp-tn temp))
+  
+  (move lexenv-tn function)
+  (move cfp-tn arg-ptr)
+
+  (loop for arg in *register-arg-tns*
+        for index from 0
+        do (loadw arg cfp-tn index))
+
+  (loadw fun lexenv-tn closure-fun-slot fun-pointer-lowtag)
+
+  (inst addi.d tmp fun (- fun-pointer-lowtag))
+  (inst jirl ra tmp (* simple-fun-insts-offset n-word-bytes))
+
+  (inst blt nargs-tn zero-tn single-value-return)
+  (move csp-tn ocfp-tn)
+
+  SINGLE-VALUE-RETURN
+  (move value a0)
+
+  (pseudo-atomic (pa-temp)
+    (save-lisp-context csp-tn cfp-tn temp))
+
+  (restore-c-registers)
+
+  (inst jirl zero-tn ra 0))
+
+(define-assembly-routine (call-into-c (:return-style :none))
+    ((:arg cfunc (any-reg) cfunc-offset)
+     (:temp ca0 (any-reg) ca0-offset)
+     (:temp ca1 (any-reg) ca1-offset)
+     (:temp value0-pass (any-reg) (result-reg-offset 0))
+     (:temp value1-pass (any-reg) (result-reg-offset 1))
+     (:temp pa-temp (any-reg) nl4-offset)
+     (:temp temp (any-reg) nl5-offset))
+  (move ocfp-tn cfp-tn)
+  (move cfp-tn csp-tn)
+  (inst addi.d csp-tn cfp-tn 32)
+  (pseudo-atomic (pa-temp)
+    (storew ocfp-tn cfp-tn)
+    (storew ra-tn cfp-tn 1)
+    (storew code-tn cfp-tn 2)
+    (save-lisp-context csp-tn cfp-tn temp))
+  (inst jirl ra-tn cfunc 0)
+  (move value0-pass ca0) 
+  (move value1-pass ca1) 
+
+  (initialize-boxed-regs (list #+sb-thread thread-base-tn))
+
+  (pseudo-atomic (pa-temp)
+    (set-up-lisp-context csp-tn cfp-tn temp)
+    (loadw ocfp-tn cfp-tn 0)
+    (loadw ra-tn cfp-tn 1)
+    (loadw code-tn cfp-tn 2))
+
+  (move csp-tn cfp-tn)
+  (move cfp-tn ocfp-tn)
+  (inst jirl zero-tn ra-tn 0)) 
+
+(define-assembly-routine (do-pending-interrupt (:return-style :none))
+    ()
+  (inst break 0)
+  (inst byte pending-interrupt-trap)
+  (emit-alignment 2))
diff --git a/src/assembly/loongarch64/support.lisp b/src/assembly/loongarch64/support.lisp
new file mode 100644
index 000000000..dbb863de2
--- /dev/null
+++ b/src/assembly/loongarch64/support.lisp
@@ -0,0 +1,43 @@
+;;;; the machine-specific support routines needed by the file assembler
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-VM")
+
+(defun generate-call-sequence (name style vop options)
+  (ecase style
+    (:raw
+     (let ((ra (make-symbol "RA")))
+       (values
+        `((inst jal ,ra (make-fixup ',name :assembly-routine)))
+        `((:temporary (:sc descriptor-reg :from (:eval 0) :to (:eval 1)
+                       :offset ra-offset)
+                      ,ra)))))
+    (:full-call-no-return
+     (let ((ra (make-symbol "RA")))
+       (values
+        `((inst jal ,ra (make-fixup ',name :assembly-routine))
+          ,@(when (and vop (assoc :save-p options))
+              `((note-this-location ,vop :single-value-return))))
+        `((:temporary (:sc descriptor-reg :from (:eval 0) :to (:eval 1)
+                        :offset ra-offset)
+                      ,ra)))))
+    (:none
+     (values
+      `((inst jal zero-tn (make-fixup ',name :assembly-routine)))
+      `()))))
+
+
+(defun generate-return-sequence (style)
+  (ecase style
+    (:raw
+     `((inst jirl zero-tn ra-tn 0)))
+    ((:none :full-call-no-return))))
+
diff --git a/src/assembly/loongarch64/tramps.lisp b/src/assembly/loongarch64/tramps.lisp
new file mode 100644
index 000000000..96dc4a33f
--- /dev/null
+++ b/src/assembly/loongarch64/tramps.lisp
@@ -0,0 +1,166 @@
+;;;; Undefined-function and closure trampoline definitions
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+(in-package "SB-VM")
+
+(defun save-to-stack (tns sp-tn &optional (start 0) floatp)
+  (loop for tn in tns
+        for i from start by (if floatp 8 n-word-bytes)
+        do (if floatp
+               (inst fstore :double tn sp-tn i)
+               (inst st.d tn sp-tn i))))
+
+(defun pop-from-stack (tns sp-tn &optional (start 0) floatp)
+  (loop for tn in tns
+        for i from start by (if floatp 8 n-word-bytes)
+        do (if floatp
+               (inst fload :double tn sp-tn i)
+               (inst ld.d tn sp-tn i))))
+
+#+gencgc
+(defmacro define-alloc-tramp-stub (alloc-tn-offset tramp-name)
+  `(define-assembly-routine
+       (,(alloc-tramp-stub-name alloc-tn-offset
+                                (if (eq tramp-name 'alloc-tramp-list)
+                                    'list
+                                    'generic))
+        (:return-style :none))
+       ((:temp free+size unsigned-reg ,alloc-tn-offset)
+        (:temp object-end descriptor-reg ,alloc-tn-offset))
+     (inst addi.d csp-tn csp-tn n-word-bytes)
+     (storew free+size csp-tn -1)
+     (move free+size lip-tn)
+     (inst jal lip-tn (make-fixup ',tramp-name :assembly-routine))
+     (move lip-tn object-end)
+     (loadw object-end csp-tn -1)
+     (inst subi csp-tn csp-tn n-word-bytes)
+     (inst jirl zero-tn lip-tn 0)))
+
+#+gencgc
+(defmacro define-alloc-tramp (tramp-name c-name)
+  `(define-assembly-routine (,tramp-name (:return-style :none))
+       ((:temp temp unsigned-reg nl0-offset)
+        (:temp ca0 any-reg ca0-offset))
+     (let* ((nl-registers
+              (loop for i in (intersection (union (list nl0-offset)
+                                                  non-descriptor-regs)
+                                           c-unsaved-registers)
+                    collect (make-reg-tn i 'unsigned-reg)))
+            (lisp-registers
+              (loop for i in (intersection
+                              (union (list ca0-offset lip-offset cfp-offset
+                                           null-offset code-offset
+                                           #+sb-thread thread-offset
+                                           lexenv-offset)
+                                     descriptor-regs)
+                              c-unsaved-registers)
+                    collect (make-reg-tn i 'descriptor-reg)))
+            (float-registers
+              (loop for i in c-unsaved-float-registers
+                    collect (make-reg-tn i 'double-reg)))
+            (float-framesize (* (length float-registers) 8))
+            (nl-framesize (* (length nl-registers) n-word-bytes))
+            (number-framesize
+              ;; New space for the number stack, making sure to respect
+              ;; number stack alignment.
+              (logandc2 (+ (+ nl-framesize float-framesize)
+                           +number-stack-alignment-mask+)
+                        +number-stack-alignment-mask+))
+            (lisp-framesize (* (length lisp-registers) n-word-bytes))
+            (nl-start (- number-framesize nl-framesize))
+            (float-start (- nl-start float-framesize)))
+       (inst subi nsp-tn nsp-tn number-framesize)
+       (save-to-stack nl-registers nsp-tn nl-start)
+       (save-lisp-context csp-tn cfp-tn temp)
+       ;; Create a new frame and save descriptor regs on the stack for GC
+       ;; to see.
+       (save-to-stack lisp-registers csp-tn)
+       (loadw ca0 csp-tn -1)
+       ;; Recover and save the size.
+       (load-alloc-free-pointer temp)
+       (inst sub.d ca0 ca0 temp)
+       (storew ca0 csp-tn -1)
+       (inst addi.d csp-tn csp-tn lisp-framesize)
+       (save-to-stack float-registers nsp-tn float-start t)
+       (inst jal ra-tn (make-fixup ,c-name :foreign))
+       (pop-from-stack float-registers nsp-tn float-start t)
+       (inst subi csp-tn csp-tn lisp-framesize)
+       (loadw temp csp-tn -1)
+       ;; Point to the end of the object, so we can fold the lowtag and
+       ;; size additions in the fast case.
+       (inst add.d ca0 ca0 temp)
+       (storew ca0 csp-tn -1)
+       (pop-from-stack lisp-registers csp-tn)
+       #-sb-thread
+       (store-foreign-symbol-value zero-tn "foreign_function_call_active" temp)
+       #+sb-thread
+       (storew zero-tn thread-base-tn thread-ffcall-active-p-slot)
+       (pop-from-stack nl-registers nsp-tn nl-start)
+       (inst addi.d nsp-tn nsp-tn number-framesize)
+       (inst jirl zero-tn lip-tn 0))))
+(define-alloc-tramp alloc-tramp "alloc")
+(define-alloc-tramp alloc-tramp-list "alloc_list")
+
+#+gencgc
+(macrolet ((define-alloc-tramp-stubs ()
+             `(progn
+                ,@(mapcar (lambda (tn-offset)
+                            `(progn
+                               (define-alloc-tramp-stub ,tn-offset alloc-tramp)
+                               (define-alloc-tramp-stub ,tn-offset alloc-tramp-list)))
+                          (union descriptor-regs non-descriptor-regs)))))
+  (define-alloc-tramp-stubs))
+
+(define-assembly-routine
+    (xundefined-tramp (:return-style :none)
+                      (:align n-lowtag-bits)
+                      (:export (undefined-tramp
+                                (+ xundefined-tramp fun-pointer-lowtag))))
+    ((:temp ra non-descriptor-reg ra-offset))
+  (inst machine-word simple-fun-widetag)
+  (inst machine-word (make-fixup 'undefined-tramp :assembly-routine))
+  (dotimes (i (- simple-fun-insts-offset 2))
+    (inst machine-word nil-value))
+
+  ;; Point reg_CODE to the header and tag it as function, since
+  ;; the debugger regards a function pointer in reg_CODE which
+  ;; doesn't point to a code object as undefined function.
+  (inst li code-tn (make-fixup 'undefined-tramp :assembly-routine))
+  (storew ocfp-tn cfp-tn 0)
+  (storew ra cfp-tn 1)
+  (error-call nil 'undefined-fun-error lexenv-tn))
+
+(define-assembly-routine
+    (xclosure-tramp (:return-style :none)
+                      (:align n-lowtag-bits)
+                      (:export (closure-tramp
+                                (+ xclosure-tramp fun-pointer-lowtag))))
+    ((:temp function descriptor-reg l0-offset)
+    (:temp tmp any-reg t7-offset))
+  (inst machine-word simple-fun-widetag)
+  (inst machine-word (make-fixup 'closure-tramp :assembly-routine))
+  (dotimes (i (- simple-fun-insts-offset 2))
+    (inst machine-word nil-value))
+
+  (loadw lexenv-tn lexenv-tn fdefn-fun-slot other-pointer-lowtag)
+  (loadw function lexenv-tn closure-fun-slot fun-pointer-lowtag)
+  (inst addi.d tmp function (- fun-pointer-lowtag))
+  (inst jirl zero-tn tmp (* simple-fun-insts-offset n-word-bytes)))
+
+(define-assembly-routine
+    (xfuncallable-instance-tramp (:return-style :none)
+                      (:align n-lowtag-bits)
+                      (:export (funcallable-instance-tramp
+                                (+ xfuncallable-instance-tramp fun-pointer-lowtag))))
+    ((:temp function descriptor-reg l0-offset)
+    (:temp tmp any-reg t7-offset))
+  (inst machine-word simple-fun-widetag)
+  (inst machine-word (make-fixup 'funcallable-instance-tramp :assembly-routine))
+  (dotimes (i (- simple-fun-insts-offset 2))
+    (inst machine-word nil-value))
+  (loadw lexenv-tn lexenv-tn funcallable-instance-function-slot fun-pointer-lowtag)
+  (loadw function lexenv-tn closure-fun-slot fun-pointer-lowtag)
+  (inst addi.d tmp function (- fun-pointer-lowtag))
+  (inst jirl zero-tn tmp (* simple-fun-insts-offset n-word-bytes)))
-- 
2.20.1