src/compiler/mips/nlx.lisp

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