1 ;;;; the definitions of VOPs used for non-local exit (throw, lexical
4 ;;;; This software is part of the SBCL system. See the README file for
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.
15 ;;; Make an environment-live stack TN for saving the SP for NLX entry.
16 (!def-vm-support-routine make-nlx-sp-tn (env)
18 (make-representation-tn *fixnum-primitive-type* immediate-arg-scn)
21 ;;; Make a TN for the argument count passing location for a
23 (!def-vm-support-routine make-nlx-entry-argument-start-location ()
24 (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset))
27 ;;;; save and restoring the dynamic environment
29 ;;;; These VOPs are used in the reentered function to restore the
30 ;;;; appropriate dynamic environment. Currently we only save the
31 ;;;; Current-Catch and binding stack pointer. We don't need to
32 ;;;; save/restore the current unwind-protect, since unwind-protects
33 ;;;; are implicitly processed during unwinding. If there were any
34 ;;;; additional stacks, then this would be the place to restore the
38 ;;; Return a list of TNs that can be used to snapshot the dynamic state for
39 ;;; use with the Save/Restore-Dynamic-Environment VOPs.
40 (!def-vm-support-routine make-dynamic-state-tns ()
41 (list (make-normal-tn *backend-t-primitive-type*)
42 (make-normal-tn *backend-t-primitive-type*)
43 (make-normal-tn *backend-t-primitive-type*)
44 (make-normal-tn *backend-t-primitive-type*)))
46 (define-vop (save-dynamic-state)
47 (:results (catch :scs (descriptor-reg))
48 (nfp :scs (descriptor-reg))
49 (nsp :scs (descriptor-reg))
50 (eval :scs (descriptor-reg)))
53 (load-symbol-value catch sb!impl::*current-catch-block*)
54 (let ((cur-nfp (current-nfp-tn vop)))
56 (inst mskll cur-nfp 4 nfp)))
57 (inst mskll nsp-tn 4 nsp)
58 (load-symbol-value eval sb!impl::*eval-stack-top*)))
60 (define-vop (restore-dynamic-state)
61 (:args (catch :scs (descriptor-reg))
62 (nfp :scs (descriptor-reg))
63 (nsp :scs (descriptor-reg))
64 (eval :scs (descriptor-reg)))
66 (:temporary (:sc any-reg) temp)
68 (store-symbol-value catch sb!impl::*current-catch-block*)
69 (store-symbol-value eval sb!impl::*eval-stack-top*)
70 (inst mskll nsp-tn 0 temp)
71 (let ((cur-nfp (current-nfp-tn vop)))
73 (inst bis nfp temp cur-nfp)))
74 (inst bis nsp temp nsp-tn)))
76 (define-vop (current-stack-pointer)
77 (:results (res :scs (any-reg descriptor-reg)))
81 (define-vop (current-binding-pointer)
82 (:results (res :scs (any-reg descriptor-reg)))
86 ;;;; unwind block hackery
88 ;;; Compute the address of the catch block from its TN, then store
89 ;;; into the block the current Fp, Env, Unwind-Protect, and the entry PC.
90 (define-vop (make-unwind-block)
93 (:results (block :scs (any-reg)))
94 (:temporary (:scs (descriptor-reg)) temp)
95 (:temporary (:scs (non-descriptor-reg)) ndescr)
97 (inst lda block (* (tn-offset tn) sb!vm:word-bytes) cfp-tn)
98 (load-symbol-value temp sb!impl::*current-unwind-protect-block*)
99 (storew temp block sb!vm:unwind-block-current-uwp-slot)
100 (storew cfp-tn block sb!vm:unwind-block-current-cont-slot)
101 (storew code-tn block sb!vm:unwind-block-current-code-slot)
102 (inst compute-lra-from-code temp code-tn entry-label ndescr)
103 (storew temp block sb!vm:catch-block-entry-pc-slot)))
106 ;;; This is like Make-Unwind-Block, except that we also store in the
107 ;;; specified tag, and link the block into the Current-Catch list.
108 (define-vop (make-catch-block)
110 (tag :scs (descriptor-reg)))
112 (:results (block :scs (any-reg)))
113 (:temporary (:scs (descriptor-reg)) temp)
114 (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result)
115 (:temporary (:scs (non-descriptor-reg)) ndescr)
117 (inst lda result (* (tn-offset tn) sb!vm:word-bytes) cfp-tn)
118 (load-symbol-value temp sb!impl::*current-unwind-protect-block*)
119 (storew temp result sb!vm:catch-block-current-uwp-slot)
120 (storew cfp-tn result sb!vm:catch-block-current-cont-slot)
121 (storew code-tn result sb!vm:catch-block-current-code-slot)
122 (inst compute-lra-from-code temp code-tn entry-label ndescr)
123 (storew temp result sb!vm:catch-block-entry-pc-slot)
125 (storew tag result sb!vm:catch-block-tag-slot)
126 (load-symbol-value temp sb!impl::*current-catch-block*)
127 (storew temp result sb!vm:catch-block-previous-catch-slot)
128 (store-symbol-value result sb!impl::*current-catch-block*)
130 (move result block)))
132 ;;; Just set the current unwind-protect to TN's address. This
133 ;;; instantiates an unwind block as an unwind-protect.
134 (define-vop (set-unwind-protect)
136 (:temporary (:scs (descriptor-reg)) new-uwp)
138 (inst lda new-uwp (* (tn-offset tn) sb!vm:word-bytes) cfp-tn)
139 (store-symbol-value new-uwp sb!impl::*current-unwind-protect-block*)))
142 (define-vop (unlink-catch-block)
143 (:temporary (:scs (any-reg)) block)
145 (:translate %catch-breakup)
147 (load-symbol-value block sb!impl::*current-catch-block*)
148 (loadw block block sb!vm:catch-block-previous-catch-slot)
149 (store-symbol-value block sb!impl::*current-catch-block*)))
151 (define-vop (unlink-unwind-protect)
152 (:temporary (:scs (any-reg)) block)
154 (:translate %unwind-protect-breakup)
156 (load-symbol-value block sb!impl::*current-unwind-protect-block*)
157 (loadw block block sb!vm:unwind-block-current-uwp-slot)
158 (store-symbol-value block sb!impl::*current-unwind-protect-block*)))
162 (define-vop (nlx-entry)
163 (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
164 ; would be inserted before the LRA.
167 (:results (values :more t))
168 (:temporary (:scs (descriptor-reg)) move-temp)
169 (:temporary (:sc non-descriptor-reg) temp)
171 (:save-p :force-to-stack)
174 (emit-return-pc label)
175 (note-this-location vop :non-local-entry)
176 (cond ((zerop nvals))
178 (let ((no-values (gen-label)))
179 (move null-tn (tn-ref-tn values))
180 (inst beq count no-values)
181 (loadw (tn-ref-tn values) start)
182 (emit-label no-values)))
184 (collect ((defaults))
186 (tn-ref values (tn-ref-across tn-ref)))
188 (let ((default-lab (gen-label))
189 (tn (tn-ref-tn tn-ref)))
190 (defaults (cons default-lab tn))
192 (inst move count temp)
193 (inst lda count (fixnumize -1) count)
194 (inst beq temp default-lab)
196 ((descriptor-reg any-reg)
199 (loadw move-temp start i)
200 (store-stack-tn tn move-temp)))))
202 (let ((defaulting-done (gen-label)))
204 (emit-label defaulting-done)
206 (assemble (*elsewhere*)
207 (dolist (def (defaults))
208 (emit-label (car def))
209 (let ((tn (cdr def)))
211 ((descriptor-reg any-reg)
214 (store-stack-tn tn null-tn)))))
215 (inst br zero-tn defaulting-done))))))
216 (load-stack-tn csp-tn sp)))
218 (define-vop (nlx-entry-multiple)
219 (:args (top :target dst) (start :target src) (count :target num))
220 ;; Again, no SC restrictions for the args, 'cause the loading would
221 ;; happen before the entry label.
223 (:temporary (:scs (any-reg) :from (:argument 0)) dst)
224 (:temporary (:scs (any-reg) :from (:argument 1)) src)
225 (:temporary (:scs (any-reg) :from (:argument 2)) num)
226 (:temporary (:scs (descriptor-reg)) temp)
227 (:results (new-start) (new-count))
228 (:save-p :force-to-stack)
231 (emit-return-pc label)
232 (note-this-location vop :non-local-entry)
233 (let ((loop (gen-label))
237 (load-stack-tn dst top)
241 ;; Establish results.
243 (any-reg (move dst new-start))
244 (control-stack (store-stack-tn new-start dst)))
246 (any-reg (inst move num new-count))
247 (control-stack (store-stack-tn new-count num)))
250 ;; Copy stuff on stack.
253 (inst lda src sb!vm:word-bytes src)
255 (inst lda num (fixnumize -1) num)
256 (inst lda dst sb!vm:word-bytes dst)
260 (inst move dst csp-tn))))
262 ;;; This VOP is just to force the TNs used in the cleanup onto the stack.
263 (define-vop (uwp-entry)
265 (:save-p :force-to-stack)
266 (:results (block) (start) (count))
267 (:ignore block start count)
270 (emit-return-pc label)
271 (note-this-location vop :non-local-entry)))