src/compiler/arm64/nlx.lisp

   1 ;;;; the ARM definitions of VOPs used for non-local exit (throw,
   2 ;;;; lexical exit, etc.)
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!VM")
  14
  15 ;;; Make a TN for the argument count passing location for a
  16 ;;; non-local entry.
  17 (defun make-nlx-entry-arg-start-location ()
  18   (make-wired-tn *fixnum-primitive-type* immediate-arg-scn r8-offset))
  19 \f
  20 ;;; Save and restore dynamic environment.
  21 ;;;
  22 ;;; These VOPs are used in the reentered function to restore the appropriate
  23 ;;; dynamic environment.  Currently we only save the Current-Catch and binding
  24 ;;; stack pointer.  We don't need to save/restore the current unwind-protect,
  25 ;;; since unwind-protects are implicitly processed during unwinding.  If there
  26 ;;; were any additional stacks, then this would be the place to restore the top
  27 ;;; pointers.
  28
  29 (define-vop (save-dynamic-state)
  30   (:results (catch :scs (descriptor-reg))
  31             (nfp :scs (descriptor-reg))
  32             (nsp :scs (descriptor-reg)))
  33   (:vop-var vop)
  34   (:generator 13
  35     (load-tl-symbol-value catch *current-catch-block*)
  36     (let ((cur-nfp (current-nfp-tn vop)))
  37       (when cur-nfp
  38         (move nfp cur-nfp)))
  39     (inst mov-sp nsp nsp-tn)))
  40
  41 (define-vop (restore-dynamic-state)
  42   (:args (catch :scs (descriptor-reg))
  43          (nfp :scs (descriptor-reg))
  44          (nsp :scs (descriptor-reg)))
  45   (:vop-var vop)
  46   (:generator 10
  47     (store-tl-symbol-value catch *current-catch-block*)
  48     (let ((cur-nfp (current-nfp-tn vop)))
  49       (when cur-nfp
  50         (move cur-nfp nfp)))
  51     (inst mov-sp nsp-tn nsp)))
  52
  53 (define-vop (current-stack-pointer)
  54   (:results (res :scs (any-reg descriptor-reg)))
  55   (:generator 1
  56     (move res csp-tn)))
  57
  58 (define-vop (current-binding-pointer)
  59   (:results (res :scs (any-reg descriptor-reg)))
  60   (:generator 1
  61     (load-binding-stack-pointer res)))
  62 \f
  63 ;;;; Unwind block hackery:
  64
  65 ;;; Compute the address of the catch block from its TN, then store into the
  66 ;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
  67 ;;;
  68 (define-vop (make-unwind-block)
  69   (:args (tn))
  70   (:info entry-label)
  71   (:results (block :scs (any-reg)))
  72   (:temporary (:scs (descriptor-reg)) temp)
  73   (:temporary (:scs (interior-reg)) lip)
  74   (:generator 22
  75     (inst add block cfp-tn (add-sub-immediate (* (tn-offset tn) n-word-bytes)))
  76     (load-tl-symbol-value temp *current-unwind-protect-block*)
  77     #.(assert (and (= unwind-block-uwp-slot 0)
  78                    (= unwind-block-cfp-slot 1)))
  79     (inst stp temp cfp-tn (@ block))
  80     (inst compute-lra temp lip entry-label)
  81     #.(assert (and (= unwind-block-code-slot 2)
  82                    (= unwind-block-entry-pc-slot 3)))
  83     (inst stp code-tn temp (@ block (* n-word-bytes 2)))))
  84
  85 ;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
  86 ;;; link the block into the Current-Catch list.
  87 ;;;
  88 (define-vop (make-catch-block)
  89   (:args (tn) (tag :scs (any-reg descriptor-reg)))
  90   (:info entry-label)
  91   (:results (block :scs (any-reg)))
  92   (:temporary (:scs (descriptor-reg)) temp)
  93   (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result)
  94   (:temporary (:scs (interior-reg)) lip)
  95   (:generator 44
  96     (inst add result cfp-tn (add-sub-immediate (* (tn-offset tn) n-word-bytes)))
  97     (load-tl-symbol-value temp *current-unwind-protect-block*)
  98     #.(assert (and (= catch-block-uwp-slot 0)
  99                    (= catch-block-cfp-slot 1)))
 100     (inst stp temp cfp-tn (@ result))
 101     #.(assert (and (= catch-block-code-slot 2)
 102                    (= catch-block-entry-pc-slot 3)))
 103     (inst compute-lra temp lip entry-label)
 104     (inst stp code-tn temp (@ result (* n-word-bytes 2)))
 105     #.(assert (and (= catch-block-tag-slot 4)
 106                    (= catch-block-previous-catch-slot 5)))
 107     (load-tl-symbol-value temp *current-catch-block*)
 108     (inst stp tag temp (@ result (* n-word-bytes 4)))
 109     (store-tl-symbol-value result *current-catch-block*)
 110
 111     (move block result)))
 112
 113 ;;; Just set the current unwind-protect to TN's address.  This
 114 ;;; instantiates an unwind block as an unwind-protect.
 115 (define-vop (set-unwind-protect)
 116   (:args (tn))
 117   (:temporary (:scs (descriptor-reg)) new-uwp)
 118   (:generator 7
 119     (inst add new-uwp cfp-tn (add-sub-immediate (* (tn-offset tn) n-word-bytes)))
 120     (store-tl-symbol-value new-uwp *current-unwind-protect-block*)))
 121
 122 (define-vop (unlink-catch-block)
 123   (:temporary (:scs (any-reg)) block)
 124   (:policy :fast-safe)
 125   (:translate %catch-breakup)
 126   (:generator 17
 127     (load-tl-symbol-value block *current-catch-block*)
 128     (loadw block block catch-block-previous-catch-slot)
 129     (store-tl-symbol-value block *current-catch-block*)))
 130
 131 (define-vop (unlink-unwind-protect)
 132   (:temporary (:scs (any-reg)) block)
 133   (:policy :fast-safe)
 134   (:translate %unwind-protect-breakup)
 135   (:generator 17
 136     (load-tl-symbol-value block *current-unwind-protect-block*)
 137     (loadw block block unwind-block-uwp-slot)
 138     (store-tl-symbol-value block *current-unwind-protect-block*)))
 139 \f
 140 ;;;; NLX entry VOPs:
 141
 142 (define-vop (nlx-entry)
 143   (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
 144               ; would be inserted before the LRA.
 145          (start)
 146          (count))
 147   (:results (values :more t :from :load))
 148   (:temporary (:scs (descriptor-reg)) move-temp)
 149   (:info label nvals)
 150   (:save-p :force-to-stack)
 151   (:vop-var vop)
 152   (:generator 30
 153     (emit-return-pc label)
 154     (note-this-location vop :non-local-entry)
 155     (cond ((zerop nvals))
 156           ((= nvals 1)
 157            (assemble ()
 158              (move (tn-ref-tn values) null-tn)
 159              (inst cbz count zero)
 160              (loadw (tn-ref-tn values) start)
 161              ZERO))
 162           (t
 163            (do ((i 0 (1+ i))
 164                 (tn-ref values (tn-ref-across tn-ref)))
 165                ((null tn-ref))
 166              (let ((tn (tn-ref-tn tn-ref)))
 167                (inst subs count count (fixnumize 1))
 168                (sc-case tn
 169                  ((descriptor-reg any-reg)
 170                   (assemble ()
 171                     (move tn null-tn)
 172                     (inst b :lt LESS-THAN)
 173                     (loadw tn start i)
 174                     LESS-THAN))
 175                  (control-stack
 176                   (assemble ()
 177                     (move move-temp null-tn)
 178                     (inst b :lt LESS-THAN)
 179                     (loadw move-temp start i)
 180                     LESS-THAN
 181                     (store-stack-tn tn move-temp))))))))
 182     (load-stack-tn csp-tn sp)))
 183
 184 (define-vop (nlx-entry-multiple)
 185   (:args (top :target result)
 186          (src)
 187          (count :target count-words))
 188   ;; Again, no SC restrictions for the args, 'cause the loading would
 189   ;; happen before the entry label.
 190   (:info label)
 191   (:temporary (:scs (any-reg)) dst)
 192   (:temporary (:scs (descriptor-reg)) temp)
 193   (:temporary (:scs (descriptor-reg)) count-words)
 194   (:results (result :scs (any-reg) :from (:argument 0))
 195             (num :scs (any-reg) :from (:argument 0)))
 196   (:save-p :force-to-stack)
 197   (:vop-var vop)
 198   (:generator 30
 199     (emit-return-pc label)
 200     (note-this-location vop :non-local-entry)
 201
 202     ;; Setup results, and test for the zero value case.
 203     (load-stack-tn result top)
 204     (inst mov num 0)
 205     ;; Shift and check for zero in one go
 206     (inst adds count-words zr-tn (lsl count (- word-shift n-fixnum-tag-bits)))
 207     (inst b :eq DONE)
 208
 209     ;; Compute dst as one slot down from result, because we inc the index
 210     ;; before we use it.
 211     (inst sub dst result n-word-bytes)
 212
 213     ;; Copy stuff down the stack.
 214     LOOP
 215     (inst ldr temp (@ src num))
 216     (inst add num num n-word-bytes)
 217     (inst cmp num count-words)
 218     (inst str temp (@ dst num))
 219     (inst b :ne LOOP)
 220
 221     ;; Reset the CSP.
 222     DONE
 223     (inst add csp-tn result num)
 224     (inst lsr num num (- word-shift n-fixnum-tag-bits))))
 225
 226 ;;; This VOP is just to force the TNs used in the cleanup onto the stack.
 227 ;;;
 228 (define-vop (uwp-entry)
 229   (:info label)
 230   (:save-p :force-to-stack)
 231   (:results (block) (start) (count))
 232   (:ignore block start count)
 233   (:vop-var vop)
 234   (:generator 0
 235     (emit-return-pc label)
 236     (note-this-location vop :non-local-entry)))
 237
 238 (define-vop (unwind-to-frame-and-call)
 239   (:args (ofp :scs (descriptor-reg))
 240          (uwp :scs (descriptor-reg))
 241          (function :scs (descriptor-reg) :to :load :target saved-function))
 242   (:arg-types system-area-pointer system-area-pointer t)
 243   (:temporary (:sc unsigned-reg) temp)
 244   (:temporary (:sc descriptor-reg :offset r8-offset) saved-function)
 245   (:temporary (:sc unsigned-reg :offset r0-offset) block)
 246   (:temporary (:sc descriptor-reg :offset lexenv-offset) lexenv)
 247   (:temporary (:scs (interior-reg)) lip)
 248   (:temporary (:sc descriptor-reg :offset nargs-offset) nargs)
 249   (:vop-var vop)
 250   (:generator 22
 251     (let ((entry-label (gen-label)))
 252       ;; Store the function into a non-stack location, since we'll be
 253       ;; unwinding the stack and destroying register contents before we
 254       ;; use it.  It turns out that R8 is preserved as part of the
 255       ;; normal multiple-value handling of an unwind, so use that.
 256       (move saved-function function)
 257
 258       ;; Allocate space for magic UWP block.
 259       (move block csp-tn)
 260       (inst add csp-tn block (* unwind-block-size n-word-bytes))
 261
 262       ;; Set up magic catch / UWP block.
 263
 264       (loadw temp uwp sap-pointer-slot other-pointer-lowtag)
 265       (storew temp block unwind-block-uwp-slot)
 266       (loadw temp ofp sap-pointer-slot other-pointer-lowtag)
 267       (storew temp block unwind-block-cfp-slot)
 268       ;; Don't need to save code at unwind-block-code-slot since
 269       ;; it's not going to be used and will be overwritten after the
 270       ;; function call
 271
 272       (inst compute-lra temp lip entry-label)
 273       (storew temp block catch-block-entry-pc-slot)
 274
 275       ;; Run any required UWPs.
 276       (load-inline-constant tmp-tn '(:fixup unwind :assembly-routine) lip)
 277       (inst br tmp-tn)
 278
 279       (emit-return-pc ENTRY-LABEL)
 280       (inst mov nargs 0)
 281
 282       (move lexenv saved-function)
 283
 284       (loadw saved-function lexenv closure-fun-slot fun-pointer-lowtag)
 285       (lisp-jump saved-function lip))))