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 (define-vop (save-dynamic-state)
  25   (:results (catch :scs (descriptor-reg))
  26             (nfp :scs (descriptor-reg))
  27             (nsp :scs (descriptor-reg)))
  28   (:vop-var vop)
  29   (:generator 13
  30     (load-symbol-value catch *current-catch-block*)
  31     (let ((cur-nfp (current-nfp-tn vop)))
  32       (when cur-nfp
  33         (move nfp cur-nfp)))
  34     (move nsp nsp-tn)))
  35
  36 (define-vop (restore-dynamic-state)
  37   (:args (catch :scs (descriptor-reg))
  38          (nfp :scs (descriptor-reg))
  39          (nsp :scs (descriptor-reg)))
  40   (:vop-var vop)
  41   (:generator 10
  42     (store-symbol-value catch *current-catch-block*)
  43     (let ((cur-nfp (current-nfp-tn vop)))
  44       (when cur-nfp
  45         (move cur-nfp nfp)))
  46     (move nsp-tn nsp)))
  47
  48 (define-vop (current-stack-pointer)
  49   (:results (res :scs (any-reg descriptor-reg)))
  50   (:generator 1
  51     (move res csp-tn)))
  52
  53 (define-vop (current-binding-pointer)
  54   (:results (res :scs (any-reg descriptor-reg)))
  55   (:generator 1
  56     (move res bsp-tn)))
  57
  58
  59 \f
  60 ;;;; Unwind block hackery:
  61
  62 ;;; Compute the address of the catch block from its TN, then store into the
  63 ;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
  64 ;;;
  65 (define-vop (make-unwind-block)
  66   (:args (tn))
  67   (:info entry-label)
  68   (:results (block :scs (any-reg)))
  69   (:temporary (:scs (descriptor-reg)) temp)
  70   (:temporary (:scs (non-descriptor-reg)) ndescr)
  71   (:generator 22
  72     (inst addu block cfp-tn (* (tn-offset tn) n-word-bytes))
  73     (load-symbol-value temp *current-unwind-protect-block*)
  74     (storew temp block unwind-block-current-uwp-slot)
  75     (storew cfp-tn block unwind-block-current-cont-slot)
  76     (storew code-tn block unwind-block-current-code-slot)
  77     (inst compute-lra-from-code temp code-tn entry-label ndescr)
  78     (storew temp block catch-block-entry-pc-slot)))
  79
  80
  81 ;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
  82 ;;; link the block into the Current-Catch list.
  83 ;;;
  84 (define-vop (make-catch-block)
  85   (:args (tn)
  86          (tag :scs (any-reg descriptor-reg)))
  87   (:info entry-label)
  88   (:results (block :scs (any-reg)))
  89   (:temporary (:scs (descriptor-reg)) temp)
  90   (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result)
  91   (:temporary (:scs (non-descriptor-reg)) ndescr)
  92   (:generator 44
  93     (inst addu result cfp-tn (* (tn-offset tn) n-word-bytes))
  94     (load-symbol-value temp *current-unwind-protect-block*)
  95     (storew temp result catch-block-current-uwp-slot)
  96     (storew cfp-tn result catch-block-current-cont-slot)
  97     (storew code-tn result catch-block-current-code-slot)
  98     (inst compute-lra-from-code temp code-tn entry-label ndescr)
  99     (storew temp result catch-block-entry-pc-slot)
 100
 101     (storew tag result catch-block-tag-slot)
 102     (load-symbol-value temp *current-catch-block*)
 103     (storew temp result catch-block-previous-catch-slot)
 104     (store-symbol-value result *current-catch-block*)
 105
 106     (move block result)))
 107
 108
 109 ;;; Just set the current unwind-protect to TN's address.  This instantiates an
 110 ;;; unwind block as an unwind-protect.
 111 ;;;
 112 (define-vop (set-unwind-protect)
 113   (:args (tn))
 114   (:temporary (:scs (descriptor-reg)) new-uwp)
 115   (:generator 7
 116     (inst addu new-uwp cfp-tn (* (tn-offset tn) n-word-bytes))
 117     (store-symbol-value new-uwp *current-unwind-protect-block*)))
 118
 119
 120 (define-vop (unlink-catch-block)
 121   (:temporary (:scs (any-reg)) block)
 122   (:policy :fast-safe)
 123   (:translate %catch-breakup)
 124   (:generator 17
 125     (load-symbol-value block *current-catch-block*)
 126     (loadw block block catch-block-previous-catch-slot)
 127     (store-symbol-value block *current-catch-block*)))
 128
 129 (define-vop (unlink-unwind-protect)
 130   (:temporary (:scs (any-reg)) block)
 131   (:policy :fast-safe)
 132   (:translate %unwind-protect-breakup)
 133   (:generator 17
 134     (load-symbol-value block *current-unwind-protect-block*)
 135     (loadw block block unwind-block-current-uwp-slot)
 136     (store-symbol-value block *current-unwind-protect-block*)))
 137
 138 \f
 139 ;;;; NLX entry VOPs:
 140
 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))
 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            (let ((no-values (gen-label)))
 158              (inst beq count zero-tn no-values)
 159              (move (tn-ref-tn values) null-tn)
 160              (loadw (tn-ref-tn values) start)
 161              (emit-label no-values)))
 162           (t
 163            (collect ((defaults))
 164              (do ((i 0 (1+ i))
 165                   (tn-ref values (tn-ref-across tn-ref)))
 166                  ((null tn-ref))
 167                (let ((default-lab (gen-label))
 168                      (tn (tn-ref-tn tn-ref)))
 169                  (defaults (cons default-lab tn))
 170
 171                  (inst beq count zero-tn default-lab)
 172                  (inst addu count count (fixnumize -1))
 173                  (sc-case tn
 174                           ((descriptor-reg any-reg)
 175                            (loadw tn start i))
 176                           (control-stack
 177                            (loadw move-temp start i)
 178                            (store-stack-tn tn move-temp)))))
 179
 180              (let ((defaulting-done (gen-label)))
 181
 182                (emit-label defaulting-done)
 183
 184                (assemble (*elsewhere*)
 185                  (dolist (def (defaults))
 186                    (emit-label (car def))
 187                    (let ((tn (cdr def)))
 188                      (sc-case tn
 189                               ((descriptor-reg any-reg)
 190                                (move tn null-tn))
 191                               (control-stack
 192                                (store-stack-tn tn null-tn)))))
 193                  (inst b defaulting-done)
 194                  (inst nop))))))
 195     (load-stack-tn csp-tn sp)))
 196
 197
 198 (define-vop (nlx-entry-multiple)
 199   (:args (top :target dst) (start :target src) (count :target num))
 200   ;; Again, no SC restrictions for the args, 'cause the loading would
 201   ;; happen before the entry label.
 202   (:info label)
 203   (:temporary (:scs (any-reg) :from (:argument 0)) dst)
 204   (:temporary (:scs (any-reg) :from (:argument 1)) src)
 205   (:temporary (:scs (any-reg) :from (:argument 2)) num)
 206   (:temporary (:scs (descriptor-reg)) temp)
 207   (:results (new-start) (new-count))
 208   (:save-p :force-to-stack)
 209   (:vop-var vop)
 210   (:generator 30
 211     (emit-return-pc label)
 212     (note-this-location vop :non-local-entry)
 213     (let ((loop (gen-label))
 214           (done (gen-label)))
 215
 216       ;; Copy args.
 217       (load-stack-tn dst top)
 218       (move src start)
 219       (move num count)
 220
 221       ;; Establish results.
 222       (sc-case new-start
 223         (any-reg (move new-start dst))
 224         (control-stack (store-stack-tn new-start dst)))
 225       (inst beq num zero-tn done)
 226       (sc-case new-count
 227         (any-reg (inst move new-count num))
 228         (control-stack (store-stack-tn new-count num)))
 229
 230       ;; Copy stuff on stack.
 231       (emit-label loop)
 232       (loadw temp src)
 233       (inst addu src src n-word-bytes)
 234       (storew temp dst)
 235       (inst addu num num (fixnumize -1))
 236       (inst bne num zero-tn loop)
 237       (inst addu dst dst n-word-bytes)
 238
 239       (emit-label done)
 240       (inst move csp-tn dst))))
 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)))