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))
45 (eval :scs
(descriptor-reg)))
48 (load-symbol-value catch
*current-catch-block
*)
49 (let ((cur-nfp (current-nfp-tn vop
)))
53 (load-symbol-value eval
*eval-stack-top
*)))
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 (store-symbol-value eval
*eval-stack-top
*)
64 (let ((cur-nfp (current-nfp-tn vop
)))
69 (define-vop (current-stack-pointer)
70 (:results
(res :scs
(any-reg descriptor-reg
)))
74 (define-vop (current-binding-pointer)
75 (:results
(res :scs
(any-reg descriptor-reg
)))
81 ;;;; Unwind block hackery:
83 ;;; Compute the address of the catch block from its TN, then store into the
84 ;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
86 (define-vop (make-unwind-block)
89 (:results
(block :scs
(any-reg)))
90 (:temporary
(:scs
(descriptor-reg)) temp
)
91 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
93 (inst addi block cfp-tn
(* (tn-offset tn
) sb
!vm
:n-word-bytes
))
94 (load-symbol-value temp
*current-unwind-protect-block
*)
95 (storew temp block sb
!vm
:unwind-block-current-uwp-slot
)
96 (storew cfp-tn block sb
!vm
:unwind-block-current-cont-slot
)
97 (storew code-tn block sb
!vm
:unwind-block-current-code-slot
)
98 (inst compute-lra-from-code temp code-tn entry-label ndescr
)
99 (storew temp block sb
!vm
:catch-block-entry-pc-slot
)))
102 ;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
103 ;;; link the block into the Current-Catch list.
105 (define-vop (make-catch-block)
107 (tag :scs
(any-reg descriptor-reg
)))
109 (:results
(block :scs
(any-reg)))
110 (:temporary
(:scs
(descriptor-reg)) temp
)
111 (:temporary
(:scs
(descriptor-reg) :target block
:to
(:result
0)) result
)
112 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
114 (inst addi result cfp-tn
(* (tn-offset tn
) sb
!vm
:n-word-bytes
))
115 (load-symbol-value temp
*current-unwind-protect-block
*)
116 (storew temp result sb
!vm
:catch-block-current-uwp-slot
)
117 (storew cfp-tn result sb
!vm
:catch-block-current-cont-slot
)
118 (storew code-tn result sb
!vm
:catch-block-current-code-slot
)
119 (inst compute-lra-from-code temp code-tn entry-label ndescr
)
120 (storew temp result sb
!vm
:catch-block-entry-pc-slot
)
122 (storew tag result sb
!vm
:catch-block-tag-slot
)
123 (load-symbol-value temp
*current-catch-block
*)
124 (storew temp result sb
!vm
:catch-block-previous-catch-slot
)
125 (store-symbol-value result
*current-catch-block
*)
127 (move block result
)))
130 ;;; Just set the current unwind-protect to TN's address. This instantiates an
131 ;;; unwind block as an unwind-protect.
133 (define-vop (set-unwind-protect)
135 (:temporary
(:scs
(descriptor-reg)) new-uwp
)
137 (inst addi new-uwp cfp-tn
(* (tn-offset tn
) sb
!vm
:n-word-bytes
))
138 (store-symbol-value new-uwp
*current-unwind-protect-block
*)))
141 (define-vop (unlink-catch-block)
142 (:temporary
(:scs
(any-reg)) block
)
144 (:translate %catch-breakup
)
146 (load-symbol-value block
*current-catch-block
*)
147 (loadw block block sb
!vm
:catch-block-previous-catch-slot
)
148 (store-symbol-value block
*current-catch-block
*)))
150 (define-vop (unlink-unwind-protect)
151 (:temporary
(:scs
(any-reg)) block
)
153 (:translate %unwind-protect-breakup
)
155 (load-symbol-value block
*current-unwind-protect-block
*)
156 (loadw block block sb
!vm
:unwind-block-current-uwp-slot
)
157 (store-symbol-value block
*current-unwind-protect-block
*)))
163 (define-vop (nlx-entry)
164 (:args
(sp) ; Note: we can't list an sc-restriction, 'cause any load vops
165 ; would be inserted before the LRA.
168 (:results
(values :more t
))
169 (:temporary
(:scs
(descriptor-reg)) move-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)))
180 (move (tn-ref-tn values
) null-tn
)
182 (loadw (tn-ref-tn values
) start
)
183 (emit-label no-values
)))
185 (collect ((defaults))
186 (inst addic. count count
(- (fixnumize 1)))
188 (tn-ref values
(tn-ref-across tn-ref
)))
190 (let ((default-lab (gen-label))
191 (tn (tn-ref-tn tn-ref
)))
192 (defaults (cons default-lab tn
))
194 (inst subi count count
(fixnumize 1))
195 (inst blt default-lab
)
197 ((descriptor-reg any-reg
)
200 (loadw move-temp start i
)
201 (store-stack-tn tn move-temp
)))
202 (inst cmpwi count
0)))
204 (let ((defaulting-done (gen-label)))
206 (emit-label defaulting-done
)
208 (assemble (*elsewhere
*)
209 (dolist (def (defaults))
210 (emit-label (car def
))
211 (let ((tn (cdr def
)))
213 ((descriptor-reg any-reg
)
216 (store-stack-tn tn null-tn
)))))
217 (inst b defaulting-done
))))))
218 (load-stack-tn csp-tn sp
)))
221 (define-vop (nlx-entry-multiple)
222 (:args
(top :target result
) (src) (count))
223 ;; Again, no SC restrictions for the args, 'cause the loading would
224 ;; happen before the entry label.
226 (:temporary
(:scs
(any-reg)) dst
)
227 (:temporary
(:scs
(descriptor-reg)) temp
)
228 (:results
(result :scs
(any-reg) :from
(:argument
0))
229 (num :scs
(any-reg) :from
(:argument
0)))
230 (:save-p
:force-to-stack
)
233 (emit-return-pc label
)
234 (note-this-location vop
:non-local-entry
)
235 (let ((loop (gen-label))
238 ;; Setup results, and test for the zero value case.
239 (load-stack-tn result top
)
244 ;; Compute dst as one slot down from result, because we inc the index
246 (inst subi dst result
4)
248 ;; Copy stuff down the stack.
250 (inst lwzx temp src num
)
251 (inst addi num num
(fixnumize 1))
252 (inst cmpw num count
)
253 (inst stwx temp dst num
)
258 (inst add csp-tn result num
))))
261 ;;; 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
)))