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 non-local
23 (!def-vm-support-routine make-nlx-entry-arg-start-location ()
24 (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset))
26 ;;; save and restore dynamic environment.
28 ;;; These VOPs are used in the reentered function to restore the
29 ;;; appropriate dynamic environment. Currently we only save the
30 ;;; CURRENT-CATCH and binding stack pointer. We don't need to
31 ;;; save/restore the current UNWIND-PROTECT, since UNWIND-PROTECTs are
32 ;;; implicitly processed during unwinding. If there were any
33 ;;; additional stacks, then this would be the place to restore the top
37 ;;; Return a list of TNs that can be used to snapshot the dynamic
38 ;;; state for use with the Save/Restore-Dynamic-Environment VOPs.
39 (!def-vm-support-routine make-dynamic-state-tns ()
40 (make-n-tns 4 *backend-t-primitive-type*))
42 (define-vop (save-dynamic-state)
43 (:results (catch :scs (descriptor-reg))
44 (nfp :scs (descriptor-reg))
45 (nsp :scs (descriptor-reg))
46 (eval :scs (descriptor-reg)))
49 (load-symbol-value catch *current-catch-block*)
50 (let ((cur-nfp (current-nfp-tn vop)))
55 (define-vop (restore-dynamic-state)
56 (:args (catch :scs (descriptor-reg))
57 (nfp :scs (descriptor-reg))
58 (nsp :scs (descriptor-reg))
59 (eval :scs (descriptor-reg)))
62 (store-symbol-value catch *current-catch-block*)
63 (let ((cur-nfp (current-nfp-tn vop)))
68 (define-vop (current-stack-pointer)
69 (:results (res :scs (any-reg descriptor-reg)))
73 (define-vop (current-binding-pointer)
74 (:results (res :scs (any-reg descriptor-reg)))
79 ;;;; unwind block hackery:
81 ;;; Compute the address of the catch block from its TN, then store
82 ;;; into the block the current Fp, Env, Unwind-Protect, and the entry
84 (define-vop (make-unwind-block)
87 (:results (block :scs (any-reg)))
88 (:temporary (:scs (descriptor-reg)) temp)
89 (:temporary (:scs (non-descriptor-reg)) ndescr)
91 (inst add block cfp-tn (* (tn-offset tn) n-word-bytes))
92 (load-symbol-value temp *current-unwind-protect-block*)
93 (storew temp block unwind-block-current-uwp-slot)
94 (storew cfp-tn block unwind-block-current-cont-slot)
95 (storew code-tn block unwind-block-current-code-slot)
96 (inst compute-lra-from-code temp code-tn entry-label ndescr)
97 (storew temp block catch-block-entry-pc-slot)))
100 ;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
101 ;;; link the block into the Current-Catch list.
102 (define-vop (make-catch-block)
104 (tag :scs (any-reg descriptor-reg)))
106 (:results (block :scs (any-reg)))
107 (:temporary (:scs (descriptor-reg)) temp)
108 (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result)
109 (:temporary (:scs (non-descriptor-reg)) ndescr)
111 (inst add result cfp-tn (* (tn-offset tn) n-word-bytes))
112 (load-symbol-value temp *current-unwind-protect-block*)
113 (storew temp result catch-block-current-uwp-slot)
114 (storew cfp-tn result catch-block-current-cont-slot)
115 (storew code-tn result catch-block-current-code-slot)
116 (inst compute-lra-from-code temp code-tn entry-label ndescr)
117 (storew temp result catch-block-entry-pc-slot)
119 (storew tag result catch-block-tag-slot)
120 (load-symbol-value temp *current-catch-block*)
121 (storew temp result catch-block-previous-catch-slot)
122 (store-symbol-value result *current-catch-block*)
124 (move block result)))
127 ;;; Just set the current unwind-protect to TN's address. This instantiates an
128 ;;; unwind block as an unwind-protect.
129 (define-vop (set-unwind-protect)
131 (:temporary (:scs (descriptor-reg)) new-uwp)
133 (inst add new-uwp cfp-tn (* (tn-offset tn) n-word-bytes))
134 (store-symbol-value new-uwp *current-unwind-protect-block*)))
137 (define-vop (unlink-catch-block)
138 (:temporary (:scs (any-reg)) block)
140 (:translate %catch-breakup)
142 (load-symbol-value block *current-catch-block*)
143 (loadw block block catch-block-previous-catch-slot)
144 (store-symbol-value block *current-catch-block*)))
146 (define-vop (unlink-unwind-protect)
147 (:temporary (:scs (any-reg)) block)
149 (:translate %unwind-protect-breakup)
151 (load-symbol-value block *current-unwind-protect-block*)
152 (loadw block block unwind-block-current-uwp-slot)
153 (store-symbol-value block *current-unwind-protect-block*)))
159 (define-vop (nlx-entry)
160 (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
161 ; would be inserted before the LRA.
164 (:results (values :more t))
165 (:temporary (:scs (descriptor-reg)) move-temp)
167 (:save-p :force-to-stack)
170 (emit-return-pc label)
171 (note-this-location vop :non-local-entry)
172 (cond ((zerop nvals))
174 (let ((no-values (gen-label)))
176 (inst b :eq no-values)
177 (move (tn-ref-tn values) null-tn)
178 (loadw (tn-ref-tn values) start)
179 (emit-label no-values)))
181 (collect ((defaults))
182 (inst subcc count (fixnumize 1))
184 (tn-ref values (tn-ref-across tn-ref)))
186 (let ((default-lab (gen-label))
187 (tn (tn-ref-tn tn-ref)))
188 (defaults (cons default-lab tn))
190 (inst b :lt default-lab)
191 (inst subcc count (fixnumize 1))
193 ((descriptor-reg any-reg)
196 (loadw move-temp start i)
197 (store-stack-tn tn move-temp)))))
199 (let ((defaulting-done (gen-label)))
201 (emit-label defaulting-done)
203 (assemble (*elsewhere*)
204 (dolist (def (defaults))
205 (emit-label (car def))
206 (let ((tn (cdr def)))
208 ((descriptor-reg any-reg)
211 (store-stack-tn tn null-tn)))))
212 (inst b defaulting-done)
214 (load-stack-tn csp-tn sp)))
217 (define-vop (nlx-entry-multiple)
218 (:args (top :target result) (src) (count))
219 ;; Again, no SC restrictions for the args, 'cause the loading would
220 ;; happen before the entry label.
222 (:temporary (:scs (any-reg)) dst)
223 (:temporary (:scs (descriptor-reg)) temp)
224 (:results (result :scs (any-reg) :from (:argument 0))
225 (num :scs (any-reg) :from (:argument 0)))
226 (:save-p :force-to-stack)
229 (emit-return-pc label)
230 (note-this-location vop :non-local-entry)
231 (let ((loop (gen-label))
234 ;; Setup results, and test for the zero value case.
235 (load-stack-tn result top)
240 ;; Compute dst as one slot down from result, because we inc the index
242 (inst sub dst result 4)
244 ;; Copy stuff down the stack.
246 (inst ld temp src num)
247 (inst add num (fixnumize 1))
250 (inst st temp dst num)
254 (inst add csp-tn result num))))
257 ;;; This VOP is just to force the TNs used in the cleanup onto the stack.
259 (define-vop (uwp-entry)
261 (:save-p :force-to-stack)
262 (:results (block) (start) (count))
263 (:ignore block start count)
266 (emit-return-pc label)
267 (note-this-location vop :non-local-entry)))