src/compiler/mips/nlx.lisp

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