src/compiler/ppc/nlx.lisp

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