1 ;;;; the ARM definitions of VOPs used for non-local exit (throw,
2 ;;;; lexical exit, etc.)
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 (defun 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 (defun make-nlx-entry-arg-start-location ()
24 (make-wired-tn *fixnum-primitive-type
* immediate-arg-scn r8-offset
))
26 ;;; Save and restore dynamic environment.
28 ;;; These VOPs are used in the reentered function to restore the appropriate
29 ;;; dynamic environment. Currently we only save the Current-Catch and binding
30 ;;; stack pointer. We don't need to save/restore the current unwind-protect,
31 ;;; since unwind-protects are implicitly processed during unwinding. If there
32 ;;; were any additional stacks, then this would be the place to restore the top
35 (define-vop (save-dynamic-state)
36 (:results
(catch :scs
(descriptor-reg))
37 (nfp :scs
(descriptor-reg))
38 (nsp :scs
(descriptor-reg)))
41 (load-symbol-value catch
*current-catch-block
*)
42 (let ((cur-nfp (current-nfp-tn vop
)))
47 (define-vop (restore-dynamic-state)
48 (:args
(catch :scs
(descriptor-reg))
49 (nfp :scs
(descriptor-reg))
50 (nsp :scs
(descriptor-reg)))
53 (store-symbol-value catch
*current-catch-block
*)
54 (let ((cur-nfp (current-nfp-tn vop
)))
59 (define-vop (current-stack-pointer)
60 (:results
(res :scs
(any-reg descriptor-reg
)))
64 (define-vop (current-binding-pointer)
65 (:results
(res :scs
(any-reg descriptor-reg
)))
67 (load-symbol-value res
*binding-stack-pointer
*)))
69 ;;;; Unwind block hackery:
71 ;;; Compute the address of the catch block from its TN, then store into the
72 ;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
74 (define-vop (make-unwind-block)
77 (:results
(block :scs
(any-reg)))
78 (:temporary
(:scs
(descriptor-reg)) temp
)
79 (:temporary
(:scs
(interior-reg)) lip
)
81 (composite-immediate-instruction add block cfp-tn
82 (* (tn-offset tn
) n-word-bytes
))
83 (load-symbol-value temp
*current-unwind-protect-block
*)
84 (storew temp block unwind-block-current-uwp-slot
)
85 (storew cfp-tn block unwind-block-current-cont-slot
)
86 (storew code-tn block unwind-block-current-code-slot
)
87 (inst compute-lra temp lip entry-label
)
88 (storew temp block catch-block-entry-pc-slot
)))
90 ;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
91 ;;; link the block into the Current-Catch list.
93 (define-vop (make-catch-block)
94 (:args
(tn) (tag :scs
(any-reg descriptor-reg
)))
96 (:results
(block :scs
(any-reg)))
97 (:temporary
(:scs
(descriptor-reg)) temp
)
98 (:temporary
(:scs
(descriptor-reg) :target block
:to
(:result
0)) result
)
99 (:temporary
(:scs
(interior-reg)) lip
)
101 (composite-immediate-instruction
102 add result cfp-tn
(* (tn-offset tn
) n-word-bytes
))
103 (load-symbol-value temp
*current-unwind-protect-block
*)
104 (storew temp result catch-block-current-uwp-slot
)
105 (storew cfp-tn result catch-block-current-cont-slot
)
106 (storew code-tn result catch-block-current-code-slot
)
107 (inst compute-lra temp lip entry-label
)
108 (storew temp result catch-block-entry-pc-slot
)
110 (storew tag result catch-block-tag-slot
)
111 (load-symbol-value temp
*current-catch-block
*)
112 (storew temp result catch-block-previous-catch-slot
)
113 (store-symbol-value result
*current-catch-block
*)
115 (move block result
)))
117 ;;; Just set the current unwind-protect to TN's address. This
118 ;;; instantiates an unwind block as an unwind-protect.
119 (define-vop (set-unwind-protect)
121 (:temporary
(:scs
(descriptor-reg)) new-uwp
)
123 (composite-immediate-instruction
124 add new-uwp cfp-tn
(* (tn-offset tn
) n-word-bytes
))
125 (store-symbol-value new-uwp
*current-unwind-protect-block
*)))
127 (define-vop (unlink-catch-block)
128 (:temporary
(:scs
(any-reg)) block
)
130 (:translate %catch-breakup
)
132 (load-symbol-value block
*current-catch-block
*)
133 (loadw block block catch-block-previous-catch-slot
)
134 (store-symbol-value block
*current-catch-block
*)))
136 (define-vop (unlink-unwind-protect)
137 (:temporary
(:scs
(any-reg)) block
)
139 (:translate %unwind-protect-breakup
)
141 (load-symbol-value block
*current-unwind-protect-block
*)
142 (loadw block block unwind-block-current-uwp-slot
)
143 (store-symbol-value block
*current-unwind-protect-block
*)))
147 (define-vop (nlx-entry)
148 (:args
(sp) ; Note: we can't list an sc-restriction, 'cause any load vops
149 ; would be inserted before the LRA.
152 (:results
(values :more t
))
153 (:temporary
(:scs
(descriptor-reg)) move-temp
)
155 (:save-p
:force-to-stack
)
158 (emit-return-pc label
)
159 (note-this-location vop
:non-local-entry
)
160 (cond ((zerop nvals
))
163 (move (tn-ref-tn values
) null-tn
:eq
)
164 (loadw (tn-ref-tn values
) start
0 0 :ne
))
167 (tn-ref values
(tn-ref-across tn-ref
)))
169 (let ((tn (tn-ref-tn tn-ref
)))
170 (inst subs count count
(fixnumize 1))
172 ((descriptor-reg any-reg
)
173 (loadw tn start i
0 :ge
)
174 (move tn null-tn
:lt
))
176 (loadw move-temp start i
0 :ge
)
177 (store-stack-tn tn move-temp
:ge
)
178 (store-stack-tn tn null-tn
:lt
)))))))
179 (load-stack-tn move-temp sp
)
180 (store-csp move-temp
)))
182 (define-vop (nlx-entry-multiple)
183 (:args
(top :target result
) (src) (count))
184 ;; Again, no SC restrictions for the args, 'cause the loading would
185 ;; happen before the entry label.
187 (:temporary
(:scs
(any-reg)) dst
)
188 (:temporary
(:scs
(descriptor-reg)) temp
)
189 (:results
(result :scs
(any-reg) :from
(:argument
0))
190 (num :scs
(any-reg) :from
(:argument
0)))
191 (:save-p
:force-to-stack
)
194 (emit-return-pc label
)
195 (note-this-location vop
:non-local-entry
)
197 ;; Setup results, and test for the zero value case.
198 (load-stack-tn result top
)
203 ;; Compute dst as one slot down from result, because we inc the index
205 (inst sub dst result
4)
207 ;; Copy stuff down the stack.
209 (inst ldr temp
(@ src num
))
210 (inst add num num
(fixnumize 1))
212 (inst str temp
(@ dst num
))
217 (inst add temp result num
)
220 ;;; This VOP is just to force the TNs used in the cleanup onto the stack.
222 (define-vop (uwp-entry)
224 (:save-p
:force-to-stack
)
225 (:results
(block) (start) (count))
226 (:ignore block start count
)
229 (emit-return-pc label
)
230 (note-this-location vop
:non-local-entry
)))
232 (define-vop (unwind-to-frame-and-call)
233 (:args
(ofp :scs
(descriptor-reg))
234 (uwp :scs
(descriptor-reg))
235 (function :scs
(descriptor-reg) :to
:load
:target saved-function
))
236 (:arg-types system-area-pointer system-area-pointer t
)
237 (:temporary
(:sc unsigned-reg
) temp
)
238 (:temporary
(:sc descriptor-reg
:offset r8-offset
) saved-function
)
239 (:temporary
(:sc unsigned-reg
:offset r0-offset
) block
)
240 (:temporary
(:sc descriptor-reg
:offset lexenv-offset
) lexenv
)
241 (:temporary
(:scs
(interior-reg)) lip
)
242 (:temporary
(:sc descriptor-reg
:offset nargs-offset
) nargs
)
245 (let ((uwp-label (gen-label))
246 (entry-label (gen-label)))
247 ;; Store the function into a non-stack location, since we'll be
248 ;; unwinding the stack and destroying register contents before we
249 ;; use it. It turns out that R8 is preserved as part of the
250 ;; normal multiple-value handling of an unwind, so use that.
251 (move saved-function function
)
253 ;; Allocate space for magic UWP block.
255 (inst add temp block
(* unwind-block-size n-word-bytes
))
258 ;; Set up magic catch / UWP block.
260 (loadw temp uwp sap-pointer-slot other-pointer-lowtag
)
261 (storew temp block unwind-block-current-uwp-slot
)
262 (loadw temp ofp sap-pointer-slot other-pointer-lowtag
)
263 (storew temp block unwind-block-current-cont-slot
)
264 ;; Don't need to save code at unwind-block-current-code-slot since
265 ;; it's not going to be used and will be overwritten after the
268 (inst compute-lra temp lip entry-label
)
269 (storew temp block catch-block-entry-pc-slot
)
271 ;; Run any required UWPs.
272 (assemble (*elsewhere
* vop
)
273 (emit-label uwp-label
)
274 (inst word
(make-fixup 'unwind
:assembly-routine
)))
275 (inst load-from-label pc-tn lr-tn uwp-label
)
277 (emit-label ENTRY-LABEL
)
278 ;; KLUDGE: either COMPUTE-LRA computes or UNWIND jumps one
279 ;; instruction further.
283 (move lexenv saved-function
)
285 (loadw saved-function lexenv closure-fun-slot fun-pointer-lowtag
)
286 (lisp-jump saved-function
))))