src/compiler/ppc/nlx.lisp

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