1 ;;; Written by Rob MacLachlan
5 ;;; MAKE-NLX-SP-TN -- Interface
7 ;;; Make an environment-live stack TN for saving the SP for NLX entry.
9 (!def-vm-support-routine make-nlx-sp-tn (env)
11 (make-representation-tn *fixnum-primitive-type* immediate-arg-scn)
14 ;;; Make-NLX-Entry-Arg-Start-Location -- Interface
16 ;;; Make a TN for the argument count passing location for a
19 (!def-vm-support-routine make-nlx-entry-arg-start-location ()
20 (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset))
23 ;;; Save and restore dynamic environment.
25 ;;; These VOPs are used in the reentered function to restore the appropriate
26 ;;; dynamic environment. Currently we only save the Current-Catch and binding
27 ;;; stack pointer. We don't need to save/restore the current unwind-protect,
28 ;;; since unwind-protects are implicitly processed during unwinding. If there
29 ;;; were any additional stacks, then this would be the place to restore the top
33 ;;; Make-Dynamic-State-TNs -- Interface
35 ;;; Return a list of TNs that can be used to snapshot the dynamic state for
36 ;;; use with the Save/Restore-Dynamic-Environment VOPs.
38 (!def-vm-support-routine make-dynamic-state-tns ()
39 (make-n-tns 4 *backend-t-primitive-type*))
41 (define-vop (save-dynamic-state)
42 (:results (catch :scs (descriptor-reg))
43 (nfp :scs (descriptor-reg))
44 (nsp :scs (descriptor-reg)))
47 (load-symbol-value catch *current-catch-block*)
48 (let ((cur-nfp (current-nfp-tn vop)))
53 (define-vop (restore-dynamic-state)
54 (:args (catch :scs (descriptor-reg))
55 (nfp :scs (descriptor-reg))
56 (nsp :scs (descriptor-reg)))
59 (store-symbol-value catch *current-catch-block*)
60 (let ((cur-nfp (current-nfp-tn vop)))
65 (define-vop (current-stack-pointer)
66 (:results (res :scs (any-reg descriptor-reg)))
70 (define-vop (current-binding-pointer)
71 (:results (res :scs (any-reg descriptor-reg)))
77 ;;;; Unwind block hackery:
79 ;;; Compute the address of the catch block from its TN, then store into the
80 ;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
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 addi block cfp-tn (* (tn-offset tn) sb!vm:n-word-bytes))
90 (load-symbol-value temp *current-unwind-protect-block*)
91 (storew temp block sb!vm:unwind-block-current-uwp-slot)
92 (storew cfp-tn block sb!vm:unwind-block-current-cont-slot)
93 (storew code-tn block sb!vm:unwind-block-current-code-slot)
94 (inst compute-lra-from-code temp code-tn entry-label ndescr)
95 (storew temp block sb!vm: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.
101 (define-vop (make-catch-block)
103 (tag :scs (any-reg descriptor-reg)))
105 (:results (block :scs (any-reg)))
106 (:temporary (:scs (descriptor-reg)) temp)
107 (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result)
108 (:temporary (:scs (non-descriptor-reg)) ndescr)
110 (inst addi result cfp-tn (* (tn-offset tn) sb!vm:n-word-bytes))
111 (load-symbol-value temp *current-unwind-protect-block*)
112 (storew temp result sb!vm:catch-block-current-uwp-slot)
113 (storew cfp-tn result sb!vm:catch-block-current-cont-slot)
114 (storew code-tn result sb!vm:catch-block-current-code-slot)
115 (inst compute-lra-from-code temp code-tn entry-label ndescr)
116 (storew temp result sb!vm:catch-block-entry-pc-slot)
118 (storew tag result sb!vm:catch-block-tag-slot)
119 (load-symbol-value temp *current-catch-block*)
120 (storew temp result sb!vm:catch-block-previous-catch-slot)
121 (store-symbol-value result *current-catch-block*)
123 (move block result)))
126 ;;; Just set the current unwind-protect to TN's address. This instantiates an
127 ;;; unwind block as an unwind-protect.
129 (define-vop (set-unwind-protect)
131 (:temporary (:scs (descriptor-reg)) new-uwp)
133 (inst addi new-uwp cfp-tn (* (tn-offset tn) sb!vm: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 sb!vm: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 sb!vm: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 (move (tn-ref-tn values) null-tn)
178 (loadw (tn-ref-tn values) start)
179 (emit-label no-values)))
181 (collect ((defaults))
182 (inst addic. count 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 subi count count (fixnumize 1))
191 (inst blt default-lab)
193 ((descriptor-reg any-reg)
196 (loadw move-temp start i)
197 (store-stack-tn tn move-temp)))
198 (inst cmpwi count 0)))
200 (let ((defaulting-done (gen-label)))
202 (emit-label defaulting-done)
204 (assemble (*elsewhere*)
205 (dolist (def (defaults))
206 (emit-label (car def))
207 (let ((tn (cdr def)))
209 ((descriptor-reg any-reg)
212 (store-stack-tn tn null-tn)))))
213 (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 subi dst result 4)
244 ;; Copy stuff down the stack.
246 (inst lwzx temp src num)
247 (inst addi num num (fixnumize 1))
248 (inst cmpw num count)
249 (inst stwx 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)))