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