1 ;;;; the definition of non-local exit for the x86 VM
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 ;;; Make a TN for the argument count passing location for a non-local entry.
15 (defun make-nlx-entry-arg-start-location ()
16 (make-wired-tn *fixnum-primitive-type
* any-reg-sc-number ebx-offset
))
18 (defun catch-block-ea (tn)
19 (aver (sc-is tn catch-block
))
20 (make-ea :dword
:base ebp-tn
21 :disp
(frame-byte-offset (+ -
1 (tn-offset tn
) catch-block-size
))))
23 (defun unwind-block-ea (tn)
24 (aver (sc-is tn unwind-block
))
25 (make-ea :dword
:base ebp-tn
26 :disp
(frame-byte-offset (+ -
1 (tn-offset tn
) unwind-block-size
))))
29 ;;;; Save and restore dynamic environment.
31 ;;;; These VOPs are used in the reentered function to restore the
32 ;;;; appropriate dynamic environment. Currently we only save the
33 ;;;; Current-Catch. (Before sbcl-0.7.0,
34 ;;;; when there were IR1 and byte interpreters, we had to save
35 ;;;; the interpreter "eval stack" too.)
37 ;;;; We don't need to save/restore the current UNWIND-PROTECT, since
38 ;;;; UNWIND-PROTECTs are implicitly processed during unwinding.
40 ;;;; We don't need to save the BSP, because that is handled automatically.
42 (define-vop (save-dynamic-state)
43 (:results
(catch :scs
(descriptor-reg)))
45 (load-tl-symbol-value catch
*current-catch-block
*)))
47 (define-vop (restore-dynamic-state)
48 (:args
(catch :scs
(descriptor-reg)))
49 #+sb-thread
(:temporary
(:sc unsigned-reg
) temp
)
51 (store-tl-symbol-value catch
*current-catch-block
* temp
)))
53 (define-vop (current-stack-pointer)
54 (:results
(res :scs
(any-reg control-stack
)))
58 (define-vop (current-binding-pointer)
59 (:results
(res :scs
(any-reg descriptor-reg
)))
61 (load-binding-stack-pointer res
)))
63 ;;;; unwind block hackery
65 ;;; Compute the address of the catch block from its TN, then store into the
66 ;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
67 (define-vop (make-unwind-block)
70 (:temporary
(:sc unsigned-reg
) temp
)
71 (:results
(block :scs
(any-reg)))
73 (inst lea block
(unwind-block-ea tn
))
74 (load-tl-symbol-value temp
*current-unwind-protect-block
*)
75 (storew temp block unwind-block-uwp-slot
)
76 (storew ebp-tn block unwind-block-cfp-slot
)
77 (storew (make-fixup nil
:code-object entry-label
)
78 block catch-block-entry-pc-slot
)
81 (inst mov temp
(make-ea :dword
:disp
0) :fs
)
82 (storew temp block unwind-block-next-seh-frame-slot
))))
84 ;;; like MAKE-UNWIND-BLOCK, except that we also store in the specified
85 ;;; tag, and link the block into the CURRENT-CATCH list
86 (define-vop (make-catch-block)
88 (tag :scs
(any-reg descriptor-reg
) :to
(:result
1)))
90 (:results
(block :scs
(any-reg)))
91 (:temporary
(:sc descriptor-reg
) temp
)
93 (inst lea block
(catch-block-ea tn
))
94 (load-tl-symbol-value temp
*current-unwind-protect-block
*)
95 (storew temp block unwind-block-uwp-slot
)
96 (storew ebp-tn block unwind-block-cfp-slot
)
97 (storew (make-fixup nil
:code-object entry-label
)
98 block catch-block-entry-pc-slot
)
101 (inst mov temp
(make-ea :dword
:disp
0) :fs
)
102 (storew temp block unwind-block-next-seh-frame-slot
))
103 (storew tag block catch-block-tag-slot
)
104 (load-tl-symbol-value temp
*current-catch-block
*)
105 (storew temp block catch-block-previous-catch-slot
)
106 (store-tl-symbol-value block
*current-catch-block
* temp
)))
108 ;;; Just set the current unwind-protect to UWP. This instantiates an
109 ;;; unwind block as an unwind-protect.
110 (define-vop (set-unwind-protect)
111 (:args
(uwp :scs
(any-reg)))
112 #+(or sb-thread win32
)
113 (:temporary
(:sc unsigned-reg
) #+sb-thread tls
#+win32 seh-frame
)
117 (storew (make-fixup 'uwp-seh-handler
:assembly-routine
)
118 uwp unwind-block-seh-frame-handler-slot
)
121 unwind-block-next-seh-frame-slot
0))
122 (inst mov
(make-ea :dword
:disp
0) seh-frame
:fs
))
123 (store-tl-symbol-value uwp
*current-unwind-protect-block
* tls
)))
125 (define-vop (%catch-breakup
)
126 (:args
(current-block))
127 (:ignore current-block
)
128 (:temporary
(:sc unsigned-reg
) #+sb-thread tls block
)
131 (load-tl-symbol-value block
*current-catch-block
*)
132 (loadw block block catch-block-previous-catch-slot
)
133 (store-tl-symbol-value block
*current-catch-block
* tls
)))
135 (define-vop (%unwind-protect-breakup
)
136 (:args
(current-block))
137 (:ignore current-block
)
138 ;; NOTE: When we have both #+sb-thread and #+win32, we only need one temp
139 (:temporary
(:sc unsigned-reg
) block
#+sb-thread tls
#+win32 seh-frame
)
142 (load-tl-symbol-value block
*current-unwind-protect-block
*)
145 (loadw seh-frame block unwind-block-next-seh-frame-slot
)
146 (inst mov
(make-ea :dword
:disp
0) seh-frame
:fs
))
147 (loadw block block unwind-block-uwp-slot
)
148 (store-tl-symbol-value block
*current-unwind-protect-block
* tls
)))
151 (define-vop (nlx-entry)
152 ;; Note: we can't list an sc-restriction, 'cause any load vops would
153 ;; be inserted before the return-pc label.
157 (:results
(values :more t
))
158 (:temporary
(:sc descriptor-reg
) move-temp
)
160 (:save-p
:force-to-stack
)
164 (note-this-location vop
:non-local-entry
)
165 (cond ((zerop nvals
))
167 (let ((no-values (gen-label)))
168 (inst mov
(tn-ref-tn values
) nil-value
)
169 (inst test ecx-tn ecx-tn
)
170 (inst jmp
:z no-values
)
171 (loadw (tn-ref-tn values
) start -
1)
172 (emit-label no-values
)))
174 ;; FIXME: this is mostly copied from
175 ;; DEFAULT-UNKNOWN-VALUES.
176 (collect ((defaults))
178 (tn-ref values
(tn-ref-across tn-ref
)))
180 (let ((default-lab (gen-label))
181 (tn (tn-ref-tn tn-ref
))
182 (first-stack-arg-p (= i register-arg-count
)))
183 (defaults (cons default-lab
(cons tn first-stack-arg-p
)))
184 (inst cmp count
(fixnumize i
))
185 (inst jmp
:le default-lab
)
186 (when first-stack-arg-p
187 (storew edx-tn ebx-tn -
1))
189 ((descriptor-reg any-reg
)
190 (loadw tn start
(frame-word-offset (+ sp-
>fp-offset i
))))
192 (loadw move-temp start
193 (frame-word-offset (+ sp-
>fp-offset i
)))
194 (inst mov tn move-temp
)))))
195 (let ((defaulting-done (gen-label)))
196 (emit-label defaulting-done
)
197 (assemble (:elsewhere
)
198 (dolist (default (defaults))
199 (emit-label (car default
))
202 (inst mov
(second default
) nil-value
))
203 (inst jmp defaulting-done
))))))
204 (inst mov esp-tn sp
)))
206 (define-vop (nlx-entry-single)
209 (:results
(res :from
:load
))
211 (:save-p
:force-to-stack
)
215 (note-this-location vop
:non-local-entry
)
217 (inst mov esp-tn sp
)))
219 (define-vop (nlx-entry-multiple)
223 ;; Again, no SC restrictions for the args, 'cause the loading would
224 ;; happen before the entry label.
226 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
2)) ecx
)
227 (:temporary
(:sc unsigned-reg
:offset esi-offset
) esi
)
228 (:temporary
(:sc unsigned-reg
:offset edi-offset
) edi
)
229 (:temporary
(:sc descriptor-reg
) temp-dword
)
230 (:results
(result :scs
(any-reg) :from
(:argument
0))
231 (num :scs
(any-reg control-stack
)))
232 (:save-p
:force-to-stack
)
236 (note-this-location vop
:non-local-entry
)
238 (inst lea esi
(make-ea :dword
:base source
:disp
(- n-word-bytes
)))
239 ;; The 'top' arg contains the %esp value saved at the time the
240 ;; catch block was created and points to where the thrown values
245 (inst sub edi n-word-bytes
)
246 (move ecx count
) ; fixnum words == bytes
248 (inst shr ecx word-shift
)
249 ;; If we got zero, we be done.
253 (inst mov temp-dword
(make-ea :dword
:base esi
))
254 (inst sub esi n-word-bytes
)
255 (inst mov
(make-ea :dword
:base edi
) temp-dword
)
256 (inst sub edi n-word-bytes
)
258 (inst jmp
:nz copy-loop
)
260 ;; Reset the CSP at last moved arg.
261 (inst lea esp-tn
(make-ea :dword
:base edi
:disp n-word-bytes
))))
264 ;;; This VOP is just to force the TNs used in the cleanup onto the stack.
265 (define-vop (uwp-entry)
267 (:save-p
:force-to-stack
)
268 (:results
(block) (start) (count))
269 (:ignore block start count
)
273 (note-this-location vop
:non-local-entry
)))
275 (define-vop (unwind-to-frame-and-call)
276 (:args
(ofp :scs
(descriptor-reg))
277 (uwp :scs
(descriptor-reg))
278 (function :scs
(descriptor-reg) :to
:load
:target saved-function
))
279 (:arg-types system-area-pointer system-area-pointer t
)
280 (:temporary
(:sc sap-reg
) temp
)
281 (:temporary
(:sc descriptor-reg
:offset ebx-offset
) saved-function
)
282 (:temporary
(:sc unsigned-reg
:offset eax-offset
) block
)
284 ;; Store the function into a non-stack location, since we'll be
285 ;; unwinding the stack and destroying register contents before we
286 ;; use it. It turns out that EBX is preserved as part of the
287 ;; normal multiple-value handling of an unwind, so use that.
288 (move saved-function function
)
290 ;; Allocate space for magic UWP block.
291 (inst sub esp-tn
(* unwind-block-size n-word-bytes
))
292 ;; Set up magic catch / UWP block.
294 (loadw temp uwp sap-pointer-slot other-pointer-lowtag
)
295 (storew temp block unwind-block-uwp-slot
)
296 (loadw temp ofp sap-pointer-slot other-pointer-lowtag
)
297 (storew temp block unwind-block-cfp-slot
)
299 (storew (make-fixup nil
:code-object entry-label
)
301 catch-block-entry-pc-slot
)
303 ;; Run any required UWPs.
304 (inst jmp
(make-fixup 'unwind
:assembly-routine
))
307 ;; Move our saved function to where we want it now.
308 (move block saved-function
)
311 (inst xor ecx-tn ecx-tn
)
315 (make-ea :dword
:base ebp-tn
316 :disp
(* (- sp-
>fp-offset
3) n-word-bytes
)))
318 ;; Push the return-pc so it looks like we just called.
319 (pushw ebp-tn
(frame-word-offset return-pc-save-offset
))
322 (inst jmp
(make-ea :dword
:base block
323 :disp
(- (* closure-fun-slot n-word-bytes
)
324 fun-pointer-lowtag
)))))