src/compiler/ppc/nlx.lisp

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