1 ;;; -*- Package: ALPHA -*-
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.
9 ;;; **********************************************************************
11 ;;; This file contains the definitions of VOPs used for non-local exit
12 ;;; (throw, lexical exit, etc.)
14 ;;; Written by Rob MacLachlan
15 ;;; Conversion by Sean Hallgren
20 ;;; MAKE-NLX-SP-TN -- Interface
22 ;;; Make an environment-live stack TN for saving the SP for NLX entry.
24 (!def-vm-support-routine make-nlx-sp-tn (env)
26 (make-representation-tn *fixnum-primitive-type* immediate-arg-scn)
29 ;;; Make-NLX-Entry-Argument-Start-Location -- Interface
31 ;;; Make a TN for the argument count passing location for a
34 (!def-vm-support-routine make-nlx-entry-argument-start-location ()
35 (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset))
38 ;;; Save and restore dynamic environment.
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
48 ;;; Make-Dynamic-State-TNs -- Interface
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.
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*)))
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)))
66 (load-symbol-value catch sb!impl::*current-catch-block*)
67 (let ((cur-nfp (current-nfp-tn vop)))
69 (inst mskll cur-nfp 4 nfp)))
70 (inst mskll nsp-tn 4 nsp)
71 (load-symbol-value eval sb!impl::*eval-stack-top*)))
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)))
79 (:temporary (:sc any-reg) temp)
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)))
86 (inst bis nfp temp cur-nfp)))
87 (inst bis nsp temp nsp-tn)))
89 (define-vop (current-stack-pointer)
90 (:results (res :scs (any-reg descriptor-reg)))
94 (define-vop (current-binding-pointer)
95 (:results (res :scs (any-reg descriptor-reg)))
101 ;;;; Unwind block hackery:
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.
106 (define-vop (make-unwind-block)
109 (:results (block :scs (any-reg)))
110 (:temporary (:scs (descriptor-reg)) temp)
111 (:temporary (:scs (non-descriptor-reg)) ndescr)
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)))
122 ;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
123 ;;; link the block into the Current-Catch list.
125 (define-vop (make-catch-block)
127 (tag :scs (descriptor-reg)))
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)
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)
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*)
147 (move result block)))
150 ;;; Just set the current unwind-protect to TN's address. This instantiates an
151 ;;; unwind block as an unwind-protect.
153 (define-vop (set-unwind-protect)
155 (:temporary (:scs (descriptor-reg)) new-uwp)
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*)))
161 (define-vop (unlink-catch-block)
162 (:temporary (:scs (any-reg)) block)
164 (:translate %catch-breakup)
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*)))
170 (define-vop (unlink-unwind-protect)
171 (:temporary (:scs (any-reg)) block)
173 (:translate %unwind-protect-breakup)
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*)))
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.
188 (:results (values :more t))
189 (:temporary (:scs (descriptor-reg)) move-temp)
190 (:temporary (:sc non-descriptor-reg) temp)
192 (:save-p :force-to-stack)
195 (emit-return-pc label)
196 (note-this-location vop :non-local-entry)
197 (cond ((zerop nvals))
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)))
205 (collect ((defaults))
207 (tn-ref values (tn-ref-across tn-ref)))
209 (let ((default-lab (gen-label))
210 (tn (tn-ref-tn tn-ref)))
211 (defaults (cons default-lab tn))
213 (inst move count temp)
214 (inst lda count (fixnumize -1) count)
215 (inst beq temp default-lab)
217 ((descriptor-reg any-reg)
220 (loadw move-temp start i)
221 (store-stack-tn tn move-temp)))))
223 (let ((defaulting-done (gen-label)))
225 (emit-label defaulting-done)
227 (assemble (*elsewhere*)
228 (dolist (def (defaults))
229 (emit-label (car def))
230 (let ((tn (cdr def)))
232 ((descriptor-reg any-reg)
235 (store-stack-tn tn null-tn)))))
236 (inst br zero-tn defaulting-done))))))
237 (load-stack-tn csp-tn sp)))
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.
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)
253 (emit-return-pc label)
254 (note-this-location vop :non-local-entry)
255 (let ((loop (gen-label))
259 (load-stack-tn dst top)
263 ;; Establish results.
265 (any-reg (move dst new-start))
266 (control-stack (store-stack-tn new-start dst)))
268 (any-reg (inst move num new-count))
269 (control-stack (store-stack-tn new-count num)))
272 ;; Copy stuff on stack.
275 (inst lda src sb!vm:word-bytes src)
277 (inst lda num (fixnumize -1) num)
278 (inst lda dst sb!vm:word-bytes dst)
282 (inst move dst csp-tn))))
285 ;;; This VOP is just to force the TNs used in the cleanup onto the stack.
287 (define-vop (uwp-entry)
289 (:save-p :force-to-stack)
290 (:results (block) (start) (count))
291 (:ignore block start count)
294 (emit-return-pc label)
295 (note-this-location vop :non-local-entry)))