src/compiler/sparc/nlx.lisp

   1 ;;;; the SPARC 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 non-local
  16 ;;; entry.
  17 (defun make-nlx-entry-arg-start-location ()
  18   (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset))
  19 \f
  20 ;;; save and restore dynamic environment.
  21 ;;;
  22 ;;; These VOPs are used in the reentered function to restore the
  23 ;;; appropriate dynamic environment.  Currently we only save the
  24 ;;; CURRENT-CATCH and binding stack pointer.  We don't need to
  25 ;;; save/restore the current UNWIND-PROTECT, since UNWIND-PROTECTs are
  26 ;;; implicitly processed during unwinding.  If there were any
  27 ;;; additional stacks, then this would be the place to restore the top
  28 ;;; pointers.
  29
  30 (define-vop (save-dynamic-state)
  31     (:results (catch :scs (descriptor-reg))
  32               (nfp :scs (descriptor-reg))
  33               (nsp :scs (descriptor-reg)))
  34   (:vop-var vop)
  35   (:generator 13
  36               (load-symbol-value catch *current-catch-block*)
  37               (let ((cur-nfp (current-nfp-tn vop)))
  38                 (when cur-nfp
  39                   (move nfp cur-nfp)))
  40               (move nsp nsp-tn)))
  41
  42 (define-vop (restore-dynamic-state)
  43     (:args (catch :scs (descriptor-reg))
  44            (nfp :scs (descriptor-reg))
  45            (nsp :scs (descriptor-reg)))
  46   (:vop-var vop)
  47   (:generator 10
  48               (store-symbol-value catch *current-catch-block*)
  49               (let ((cur-nfp (current-nfp-tn vop)))
  50                 (when cur-nfp
  51                   (move cur-nfp nfp)))
  52               (move nsp-tn nsp)))
  53
  54 (define-vop (current-stack-pointer)
  55     (:results (res :scs (any-reg descriptor-reg)))
  56   (:generator 1
  57               (move res csp-tn)))
  58
  59 (define-vop (current-binding-pointer)
  60     (:results (res :scs (any-reg descriptor-reg)))
  61   (:generator 1
  62               (move res bsp-tn)))
  63
  64 \f
  65 ;;;; unwind block hackery:
  66
  67 ;;; Compute the address of the catch block from its TN, then store
  68 ;;; into the block the current Fp, Env, Unwind-Protect, and the entry
  69 ;;; PC.
  70 (define-vop (make-unwind-block)
  71   (:args (tn))
  72   (:info entry-label)
  73   (:results (block :scs (any-reg)))
  74   (:temporary (:scs (descriptor-reg)) temp)
  75   (:temporary (:scs (non-descriptor-reg)) ndescr)
  76   (:generator 22
  77     (inst add block cfp-tn (* (tn-offset tn) n-word-bytes))
  78     (load-symbol-value temp *current-unwind-protect-block*)
  79     (storew temp block unwind-block-uwp-slot)
  80     (storew cfp-tn block unwind-block-cfp-slot)
  81     (storew code-tn block unwind-block-code-slot)
  82     (inst compute-lra-from-code temp code-tn entry-label ndescr)
  83     (storew temp block catch-block-entry-pc-slot)))
  84
  85
  86 ;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
  87 ;;; link the block into the Current-Catch list.
  88 (define-vop (make-catch-block)
  89   (:args (tn)
  90          (tag :scs (any-reg descriptor-reg)))
  91   (:info entry-label)
  92   (:results (block :scs (any-reg)))
  93   (:temporary (:scs (descriptor-reg)) temp)
  94   (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result)
  95   (:temporary (:scs (non-descriptor-reg)) ndescr)
  96   (:generator 44
  97     (inst add result cfp-tn (* (tn-offset tn) n-word-bytes))
  98     (load-symbol-value temp *current-unwind-protect-block*)
  99     (storew temp result catch-block-uwp-slot)
 100     (storew cfp-tn result catch-block-cfp-slot)
 101     (storew code-tn result catch-block-code-slot)
 102     (inst compute-lra-from-code temp code-tn entry-label ndescr)
 103     (storew temp result catch-block-entry-pc-slot)
 104
 105     (storew tag result catch-block-tag-slot)
 106     (load-symbol-value temp *current-catch-block*)
 107     (storew temp result catch-block-previous-catch-slot)
 108     (store-symbol-value result *current-catch-block*)
 109
 110     (move block result)))
 111
 112
 113 ;;; Just set the current unwind-protect to TN's address.  This instantiates an
 114 ;;; 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 (* (tn-offset tn) n-word-bytes))
 120     (store-symbol-value new-uwp *current-unwind-protect-block*)))
 121
 122
 123 (define-vop (unlink-catch-block)
 124   (:temporary (:scs (any-reg)) block)
 125   (:policy :fast-safe)
 126   (:translate %catch-breakup)
 127   (:generator 17
 128     (load-symbol-value block *current-catch-block*)
 129     (loadw block block catch-block-previous-catch-slot)
 130     (store-symbol-value block *current-catch-block*)))
 131
 132 (define-vop (unlink-unwind-protect)
 133   (:temporary (:scs (any-reg)) block)
 134   (:policy :fast-safe)
 135   (:translate %unwind-protect-breakup)
 136   (:generator 17
 137     (load-symbol-value block *current-unwind-protect-block*)
 138     (loadw block block unwind-block-uwp-slot)
 139     (store-symbol-value block *current-unwind-protect-block*)))
 140
 141 \f
 142 ;;;; NLX entry VOPs:
 143
 144
 145 (define-vop (nlx-entry)
 146   (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
 147               ; would be inserted before the LRA.
 148          (start)
 149          (count))
 150   (:results (values :more t))
 151   (:temporary (:scs (descriptor-reg)) move-temp)
 152   (:info label nvals)
 153   (:save-p :force-to-stack)
 154   (:vop-var vop)
 155   (:generator 30
 156     (emit-return-pc label)
 157     (note-this-location vop :non-local-entry)
 158     (cond ((zerop nvals))
 159           ((= nvals 1)
 160            (let ((no-values (gen-label)))
 161              (inst cmp count)
 162              (inst b :eq no-values)
 163              (move (tn-ref-tn values) null-tn)
 164              (loadw (tn-ref-tn values) start)
 165              (emit-label no-values)))
 166           (t
 167            (collect ((defaults))
 168              (inst subcc count (fixnumize 1))
 169              (do ((i 0 (1+ i))
 170                   (tn-ref values (tn-ref-across tn-ref)))
 171                  ((null tn-ref))
 172                (let ((default-lab (gen-label))
 173                      (tn (tn-ref-tn tn-ref)))
 174                  (defaults (cons default-lab tn))
 175
 176                  (inst b :lt default-lab)
 177                  (inst subcc count (fixnumize 1))
 178                  (sc-case tn
 179                           ((descriptor-reg any-reg)
 180                            (loadw tn start i))
 181                           (control-stack
 182                            (loadw move-temp start i)
 183                            (store-stack-tn tn move-temp)))))
 184
 185              (let ((defaulting-done (gen-label)))
 186
 187                (emit-label defaulting-done)
 188
 189                (assemble (*elsewhere*)
 190                  (dolist (def (defaults))
 191                    (emit-label (car def))
 192                    (let ((tn (cdr def)))
 193                      (sc-case tn
 194                               ((descriptor-reg any-reg)
 195                                (move tn null-tn))
 196                               (control-stack
 197                                (store-stack-tn tn null-tn)))))
 198                  (inst b defaulting-done)
 199                  (inst nop))))))
 200     (load-stack-tn csp-tn sp)))
 201
 202
 203 (define-vop (nlx-entry-multiple)
 204   (:args (top :target result) (src) (count))
 205   ;; Again, no SC restrictions for the args, 'cause the loading would
 206   ;; happen before the entry label.
 207   (:info label)
 208   (:temporary (:scs (any-reg)) dst)
 209   (:temporary (:scs (descriptor-reg)) temp)
 210   (:results (result :scs (any-reg) :from (:argument 0))
 211             (num :scs (any-reg) :from (:argument 0)))
 212   (:save-p :force-to-stack)
 213   (:vop-var vop)
 214   (:generator 30
 215     (emit-return-pc label)
 216     (note-this-location vop :non-local-entry)
 217     (let ((loop (gen-label))
 218           (done (gen-label)))
 219
 220       ;; Setup results, and test for the zero value case.
 221       (load-stack-tn result top)
 222       (inst cmp count)
 223       (inst b :eq done)
 224       (inst li num 0)
 225
 226       ;; Compute dst as one slot down from result, because we inc the index
 227       ;; before we use it.
 228       (inst sub dst result 4)
 229
 230       ;; Copy stuff down the stack.
 231       (emit-label loop)
 232       (inst ld temp src num)
 233       (inst add num (fixnumize 1))
 234       (inst cmp num count)
 235       (inst b :ne loop)
 236       (inst st temp dst num)
 237
 238       ;; Reset the CSP.
 239       (emit-label done)
 240       (inst add csp-tn result num))))
 241
 242
 243 ;;; This VOP is just to force the TNs used in the cleanup onto the stack.
 244 ;;;
 245 (define-vop (uwp-entry)
 246   (:info label)
 247   (:save-p :force-to-stack)
 248   (:results (block) (start) (count))
 249   (:ignore block start count)
 250   (:vop-var vop)
 251   (:generator 0
 252     (emit-return-pc label)
 253     (note-this-location vop :non-local-entry)))
 254