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

#+gencgc
(macrolet ((define-alloc-tramp (lisp-name c-name)
 `(define-assembly-routine (,lisp-name (:return-style :none))
    ((:temp nl0 unsigned-reg nl0-offset)
     (:temp nl1 unsigned-reg nl1-offset))
  (flet ((reg (offset sc)
           (make-random-tn
            :kind :normal
            :sc (sc-or-lose sc)
            :offset offset))
         (reverse-pairs (list)
           (let (result)
             (loop for (a b) on list by #'cddr
                   do
                   (push b result)
                   (push a result))
             result)))
    (let ((nl-registers (loop for i to 9
                              collect (reg i 'unsigned-reg)))
          (lisp-registers (loop for i from r0-offset to r9-offset
                                collect (reg i 'unsigned-reg)))
          (float-registers (loop for i below 32
                                 collect (reg i 'complex-double-reg))))
      (macrolet  ((map-pairs (op base start offsets
                              &key pre-index post-index
                                   (delta 16))
                    `(let ((offsets ,(if (eq op 'ldp)
                                         `(reverse-pairs ,offsets)
                                         offsets)))
                       (loop with offset = ,start
                             for first = t then nil
                             for (a b . next) on offsets by #'cddr
                             for last = (not next)
                             do (inst ,op a b
                                      (@ ,base (or (and first ,pre-index)
                                                   (and last ,post-index)
                                                   offset)
                                               (cond ((and last ,post-index)
                                                      :post-index)
                                                     ((and first ,pre-index)
                                                      :pre-index)
                                                     (t
                                                      :offset))))
                                (incf offset ,delta)))))
        (map-pairs stp nsp-tn 0 nl-registers :pre-index -80)
        (inst mov nl0 tmp-tn) ;; size
        #+sb-thread
        (inst stp cfp-tn csp-tn (@ thread-tn (* thread-control-frame-pointer-slot n-word-bytes)))
        #-sb-thread
        (progn
          ;; Each of these loads of a fixup loads the address of a linkage table entry,
          ;; that is, if LINKAGE-TABLE-SPACE-START is #xF0200000, then the first load puts
          ;; #xF0200000+something, not the address of current_control_frame_pointer,
          ;; into register nl1.
          ;; This is kinda dumb because first of all we could have calculated the address
          ;; of the linkage entry instead of loading it. Second, it's unnecessarily
          ;; double-indirect. I wonder if there's a way to remove double-indirection.
          ;; The ohly way I can see doing that is for os_link_runtime() to poke bytes
          ;; into this assembly code in the manner of the system's dynamic loader.
          (load-inline-constant nl1 '(:fixup "current_control_frame_pointer" :foreign-dataref))
          (inst ldr nl1 (@ nl1)) ; now load the address of the C variable
          (inst str cfp-tn (@ nl1))
          (load-inline-constant nl1 '(:fixup "current_control_stack_pointer" :foreign-dataref))
          (inst ldr nl1 (@ nl1)) ; "
          (inst str csp-tn (@ nl1))
          (load-inline-constant nl1 '(:fixup "foreign_function_call_active" :foreign-dataref))
          (inst ldr nl1 (@ nl1)) ; "
          ;; storing NULL ensures at least 1 set bit somewhere in the low 4 bytes
          (inst str (32-bit-reg null-tn) (@ nl1))) ; (alien variable is 4 bytes, not 8)
        ;; Create a new frame
        (inst add csp-tn csp-tn (+ 32 80))
        (inst stp cfp-tn lr-tn (@ csp-tn -112))

        (map-pairs stp csp-tn -80 lisp-registers)
        (map-pairs stp nsp-tn 0 float-registers :pre-index -512 :delta 32)

        (load-inline-constant nl1 '(:fixup ,c-name :foreign))
        (inst blr nl1)

        (map-pairs ldp nsp-tn 480 float-registers :post-index 512 :delta -32)
        (map-pairs ldp csp-tn -16 lisp-registers :delta -16)

        (inst ldr lr-tn (@ csp-tn -104))

        (inst sub csp-tn csp-tn (+ 32 80)) ;; deallocate the frame
        #+sb-thread
        (inst str zr-tn (@ thread-tn (* thread-control-stack-pointer-slot n-word-bytes)))
        #-sb-thread
        (progn
          ;; We haven't restored NL1 yet, so it's ok to use as a scratch register here.
          ;; It gets restored just prior to the RET instruction.
          (load-inline-constant nl1 '(:fixup "foreign_function_call_active" :foreign-dataref))
          (inst ldr nl1 (@ nl1))
          (inst str (32-bit-reg zr-tn) (@ nl1)))

        (inst mov tmp-tn nl0) ;; result

        (map-pairs ldp nsp-tn 64 nl-registers :post-index 80 :delta -16)
        (inst ret)))))))
  (define-alloc-tramp alloc-tramp "alloc")
  (define-alloc-tramp list-alloc-tramp "alloc_list"))

(define-assembly-routine
    (xundefined-tramp (:return-style :none)
                      (:align n-lowtag-bits)
                      (:export undefined-tramp
                               (undefined-tramp-tagged
                                (+ xundefined-tramp
                                   fun-pointer-lowtag))))
    ((:temp fun any-reg r9-offset))
  HEADER
  (inst dword simple-fun-widetag)
  (inst dword (make-fixup 'undefined-tramp-tagged
                          :assembly-routine))
  (dotimes (i (- simple-fun-insts-offset 2))
    (inst dword nil-value))

  UNDEFINED-TRAMP
  (inst str lr-tn (@ cfp-tn 8))
  (emit-error-break nil cerror-trap (error-number-or-lose 'undefined-fun-error)
                    (list lexenv-tn))
  (loadw fun lexenv-tn closure-fun-slot fun-pointer-lowtag)
  (inst add lr-tn fun (+ (- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag)
                          4))
  (inst br lr-tn))

(define-assembly-routine
    (xundefined-alien-tramp (:return-style :none)
                      (:align n-lowtag-bits)
                      (:export undefined-alien-tramp
                               (undefined-alien-tramp-tagged
                                (+ xundefined-alien-tramp
                                   fun-pointer-lowtag))))
    ((:temp r9-tn unsigned-reg r9-offset))
  HEADER
  (inst dword simple-fun-widetag)
  (inst dword (make-fixup 'undefined-alien-tramp-tagged
                         :assembly-routine))
  (dotimes (i (- simple-fun-insts-offset 2))
    (inst dword nil-value))

  UNDEFINED-ALIEN-TRAMP
  (inst str lr-tn (@ cfp-tn 8))
  (error-call nil 'undefined-alien-fun-error r9-tn))

(define-assembly-routine
    (xclosure-tramp (:return-style :none)
                      (:align n-lowtag-bits)
                      (:export closure-tramp
                               (closure-tramp-tagged
                                (+ xclosure-tramp
                                   fun-pointer-lowtag))))
    ((:temp fun any-reg r9-offset))
  (inst dword simple-fun-widetag)
  (inst dword (make-fixup 'closure-tramp-tagged
                         :assembly-routine))
  (dotimes (i (- simple-fun-insts-offset 2))
    (inst dword nil-value))

  CLOSURE-TRAMP
  (inst str lr-tn (@ cfp-tn 8))
  (loadw lexenv-tn lexenv-tn fdefn-fun-slot other-pointer-lowtag)
  (loadw fun lexenv-tn closure-fun-slot fun-pointer-lowtag)
  (inst add lr-tn fun (+ (- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag)
                          4))
  (inst br lr-tn))

(define-assembly-routine
    (xfuncallable-instance-tramp (:return-style :none)
                      (:align n-lowtag-bits)
                      (:export (funcallable-instance-tramp
                                (+ xfuncallable-instance-tramp
                                   fun-pointer-lowtag))))
    ((:temp fun any-reg r9-offset))
  (inst dword simple-fun-widetag)
  (inst dword (make-fixup 'funcallable-instance-tramp :assembly-routine))
  (dotimes (i (- simple-fun-insts-offset 2))
    (inst dword nil-value))
  (inst str lr-tn (@ cfp-tn 8))
  (loadw lexenv-tn lexenv-tn funcallable-instance-function-slot fun-pointer-lowtag)
  (loadw fun lexenv-tn closure-fun-slot fun-pointer-lowtag)
  (inst add lr-tn fun (+ (- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag)
                          4))
  (inst br lr-tn))
