src/compiler/alpha/nlx.lisp

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