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)))
48 (load-symbol-value catch *current-catch-block*)
49 (let ((cur-nfp (current-nfp-tn vop)))
54 (define-vop (restore-dynamic-state)
55 (:args (catch :scs (descriptor-reg))
56 (nfp :scs (descriptor-reg))
57 (nsp :scs (descriptor-reg)))
60 (store-symbol-value catch *current-catch-block*)
61 (let ((cur-nfp (current-nfp-tn vop)))
66 (define-vop (current-stack-pointer)
67 (:results (res :scs (any-reg descriptor-reg)))
71 (define-vop (current-binding-pointer)
72 (:results (res :scs (any-reg descriptor-reg)))
77 ;;;; unwind block hackery:
79 ;;; Compute the address of the catch block from its TN, then store
80 ;;; into the block the current Fp, Env, Unwind-Protect, and the entry
82 (define-vop (make-unwind-block)
85 (:results (block :scs (any-reg)))
86 (:temporary (:scs (descriptor-reg)) temp)
87 (:temporary (:scs (non-descriptor-reg)) ndescr)
89 (inst add block cfp-tn (* (tn-offset tn) n-word-bytes))
90 (load-symbol-value temp *current-unwind-protect-block*)
91 (storew temp block unwind-block-current-uwp-slot)
92 (storew cfp-tn block unwind-block-current-cont-slot)
93 (storew code-tn block unwind-block-current-code-slot)
94 (inst compute-lra-from-code temp code-tn entry-label ndescr)
95 (storew temp block catch-block-entry-pc-slot)))
98 ;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
99 ;;; link the block into the Current-Catch list.
100 (define-vop (make-catch-block)
102 (tag :scs (any-reg descriptor-reg)))
104 (:results (block :scs (any-reg)))
105 (:temporary (:scs (descriptor-reg)) temp)
106 (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result)
107 (:temporary (:scs (non-descriptor-reg)) ndescr)
109 (inst add result cfp-tn (* (tn-offset tn) n-word-bytes))
110 (load-symbol-value temp *current-unwind-protect-block*)
111 (storew temp result catch-block-current-uwp-slot)
112 (storew cfp-tn result catch-block-current-cont-slot)
113 (storew code-tn result catch-block-current-code-slot)
114 (inst compute-lra-from-code temp code-tn entry-label ndescr)
115 (storew temp result catch-block-entry-pc-slot)
117 (storew tag result catch-block-tag-slot)
118 (load-symbol-value temp *current-catch-block*)
119 (storew temp result catch-block-previous-catch-slot)
120 (store-symbol-value result *current-catch-block*)
122 (move block result)))
125 ;;; Just set the current unwind-protect to TN's address. This instantiates an
126 ;;; unwind block as an unwind-protect.
127 (define-vop (set-unwind-protect)
129 (:temporary (:scs (descriptor-reg)) new-uwp)
131 (inst add new-uwp cfp-tn (* (tn-offset tn) n-word-bytes))
132 (store-symbol-value new-uwp *current-unwind-protect-block*)))
135 (define-vop (unlink-catch-block)
136 (:temporary (:scs (any-reg)) block)
138 (:translate %catch-breakup)
140 (load-symbol-value block *current-catch-block*)
141 (loadw block block catch-block-previous-catch-slot)
142 (store-symbol-value block *current-catch-block*)))
144 (define-vop (unlink-unwind-protect)
145 (:temporary (:scs (any-reg)) block)
147 (:translate %unwind-protect-breakup)
149 (load-symbol-value block *current-unwind-protect-block*)
150 (loadw block block unwind-block-current-uwp-slot)
151 (store-symbol-value block *current-unwind-protect-block*)))
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.
162 (:results (values :more t))
163 (:temporary (:scs (descriptor-reg)) move-temp)
165 (:save-p :force-to-stack)
168 (emit-return-pc label)
169 (note-this-location vop :non-local-entry)
170 (cond ((zerop nvals))
172 (let ((no-values (gen-label)))
174 (inst b :eq no-values)
175 (move (tn-ref-tn values) null-tn)
176 (loadw (tn-ref-tn values) start)
177 (emit-label no-values)))
179 (collect ((defaults))
180 (inst subcc count (fixnumize 1))
182 (tn-ref values (tn-ref-across tn-ref)))
184 (let ((default-lab (gen-label))
185 (tn (tn-ref-tn tn-ref)))
186 (defaults (cons default-lab tn))
188 (inst b :lt default-lab)
189 (inst subcc count (fixnumize 1))
191 ((descriptor-reg any-reg)
194 (loadw move-temp start i)
195 (store-stack-tn tn move-temp)))))
197 (let ((defaulting-done (gen-label)))
199 (emit-label defaulting-done)
201 (assemble (*elsewhere*)
202 (dolist (def (defaults))
203 (emit-label (car def))
204 (let ((tn (cdr def)))
206 ((descriptor-reg any-reg)
209 (store-stack-tn tn null-tn)))))
210 (inst b defaulting-done)
212 (load-stack-tn csp-tn sp)))
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.
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)
227 (emit-return-pc label)
228 (note-this-location vop :non-local-entry)
229 (let ((loop (gen-label))
232 ;; Setup results, and test for the zero value case.
233 (load-stack-tn result top)
238 ;; Compute dst as one slot down from result, because we inc the index
240 (inst sub dst result 4)
242 ;; Copy stuff down the stack.
244 (inst ld temp src num)
245 (inst add num (fixnumize 1))
248 (inst st temp dst num)
252 (inst add csp-tn result num))))
255 ;;; This VOP is just to force the TNs used in the cleanup onto the stack.
257 (define-vop (uwp-entry)
259 (:save-p :force-to-stack)
260 (:results (block) (start) (count))
261 (:ignore block start count)
264 (emit-return-pc label)
265 (note-this-location vop :non-local-entry)))