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 rbx-offset
))
18 (defun catch-block-ea (tn &optional
(offset 0))
19 (aver (sc-is tn catch-block
))
20 (ea (frame-byte-offset (- (+ -
1 (tn-offset tn
) catch-block-size
) offset
)) rbp-tn
))
22 (defun unwind-block-ea (tn &optional
(offset 0))
23 (aver (sc-is tn unwind-block
))
24 (ea (frame-byte-offset (- (+ -
1 (tn-offset tn
) unwind-block-size offset
) offset
)) rbp-tn
))
26 ;;;; Save and restore dynamic environment.
27 (define-vop (current-stack-pointer)
28 (:results
(res :scs
(any-reg control-stack
)))
32 (define-vop (current-binding-pointer)
33 (:results
(res :scs
(any-reg descriptor-reg
)))
35 (load-binding-stack-pointer res
)))
37 ;;;; unwind block hackery
39 ;;; Compute the address of the catch block from its TN, then store into the
40 ;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
43 ;; MOVAPD instruction faults if not properly aligned
44 (assert (evenp (/ (info :variable
:wired-tls
'*binding-stack-pointer
*) n-word-bytes
)))
45 (assert (= (- (info :variable
:wired-tls
'*current-catch-block
*)
46 (info :variable
:wired-tls
'*binding-stack-pointer
*))
48 (assert (= (- unwind-block-current-catch-slot unwind-block-bsp-slot
) 1)))
50 (define-vop (make-unwind-block)
53 (:temporary
(:sc unsigned-reg
) temp
)
55 (:temporary
(:sc complex-double-reg
) xmm-temp
)
56 (:results
(block :scs
(any-reg)))
59 (inst lea block
(unwind-block-ea tn
))
60 (load-tl-symbol-value temp
*current-unwind-protect-block
*)
61 (storew temp block unwind-block-uwp-slot
)
62 (storew rbp-tn block unwind-block-cfp-slot
)
63 (inst lea temp
(rip-relative-ea entry-label
))
64 (storew temp block unwind-block-entry-pc-slot
)
66 (let ((bsp (info :variable
:wired-tls
'*binding-stack-pointer
*)))
67 (inst movapd xmm-temp
(thread-tls-ea bsp
))
68 (inst movupd
(ea (* unwind-block-bsp-slot n-word-bytes
) block
) xmm-temp
))
71 (load-binding-stack-pointer temp
)
72 (storew temp block unwind-block-bsp-slot
)
73 (load-tl-symbol-value temp
*current-catch-block
*)
74 (storew temp block unwind-block-current-catch-slot
))))
76 ;;; like MAKE-UNWIND-BLOCK, except that we also store in the specified
77 ;;; tag, and link the block into the CURRENT-CATCH list
78 (define-vop (make-catch-block)
80 (tag :scs
(any-reg descriptor-reg
) :to
(:result
1)))
82 (:results
(block :scs
(any-reg)))
83 (:temporary
(:sc descriptor-reg
) temp
)
85 (:temporary
(:sc complex-double-reg
) xmm-temp
)
88 (inst lea block
(catch-block-ea tn
))
89 (load-tl-symbol-value temp
*current-unwind-protect-block
*)
90 (storew temp block catch-block-uwp-slot
)
91 (storew rbp-tn block catch-block-cfp-slot
)
92 (inst lea temp
(rip-relative-ea entry-label
))
93 (storew temp block catch-block-entry-pc-slot
)
94 (storew tag block catch-block-tag-slot
)
96 (let ((bsp #1=(info :variable
:wired-tls
'*binding-stack-pointer
*)))
97 #.
(assert (and (= (- (info :variable
:wired-tls
'*current-catch-block
*) #1#) n-word-bytes
)
98 (= (- catch-block-previous-catch-slot catch-block-bsp-slot
) 1)))
99 (inst movapd xmm-temp
(thread-tls-ea bsp
))
100 (inst movupd
(ea (* catch-block-bsp-slot n-word-bytes
) block
) xmm-temp
)
101 (store-tl-symbol-value block
*current-catch-block
*))
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
*)
107 (load-binding-stack-pointer temp
)
108 (storew temp block catch-block-bsp-slot
))))
110 ;;; Just set the current unwind-protect to UWP. This instantiates an
111 ;;; unwind block as an unwind-protect.
112 (define-vop (set-unwind-protect)
113 (:args
(uwp :scs
(any-reg)))
115 (store-tl-symbol-value uwp
*current-unwind-protect-block
*)))
117 (define-vop (%catch-breakup
)
118 (:args
(current-block))
119 (:temporary
(:sc unsigned-reg
) block
)
122 (inst mov block
(catch-block-ea current-block
123 catch-block-previous-catch-slot
))
124 (store-tl-symbol-value block
*current-catch-block
*)))
126 (define-vop (%unwind-protect-breakup
)
127 (:args
(current-block))
128 (:temporary
(:sc unsigned-reg
) block
)
131 (inst mov block
(unwind-block-ea current-block
132 unwind-block-uwp-slot
))
133 (store-tl-symbol-value block
*current-unwind-protect-block
*)))
136 (define-vop (nlx-entry)
137 ;; Note: we can't list an sc-restriction, 'cause any load vops would
138 ;; be inserted before the return-pc label.
142 (:results
(values :more t
))
143 (:temporary
(:sc descriptor-reg
) move-temp
)
145 (:save-p
:force-to-stack
)
149 (note-this-location vop
:non-local-entry
)
150 (cond ((zerop nvals
))
152 (let ((no-values (gen-label)))
153 (inst mov
(tn-ref-tn values
) nil-value
)
154 (inst test rcx-tn rcx-tn
)
155 (inst jmp
:z no-values
)
156 (loadw (tn-ref-tn values
) start -
1)
157 (emit-label no-values
)))
159 ;; FIXME: this is mostly copied from
160 ;; DEFAULT-UNKNOWN-VALUES.
161 (collect ((defaults))
163 (tn-ref values
(tn-ref-across tn-ref
)))
165 (let ((default-lab (gen-label))
166 (tn (tn-ref-tn tn-ref
))
167 (first-stack-arg-p (= i register-arg-count
)))
168 (defaults (cons default-lab
(cons tn first-stack-arg-p
)))
169 (inst cmp count
(fixnumize i
))
170 (inst jmp
:le default-lab
)
171 (when first-stack-arg-p
172 (storew rdx-tn rbx-tn -
1))
174 ((descriptor-reg any-reg
)
175 (loadw tn start
(frame-word-offset (+ sp-
>fp-offset i
))))
177 (loadw move-temp start
178 (frame-word-offset (+ sp-
>fp-offset i
)))
179 (inst mov tn move-temp
)))))
180 (let ((defaulting-done (gen-label)))
181 (emit-label defaulting-done
)
182 (assemble (:elsewhere
)
183 (dolist (default (defaults))
184 (emit-label (car default
))
187 (inst mov
(second default
) nil-value
))
188 (inst jmp defaulting-done
))))))
189 (inst mov rsp-tn sp
)))
191 (define-vop (nlx-entry-single)
194 (:results
(res :from
:load
))
196 (:save-p
:force-to-stack
)
200 (note-this-location vop
:non-local-entry
)
202 (inst mov rsp-tn sp
)))
204 (define-vop (nlx-entry-multiple)
205 (:args
(top :target result
212 (note-this-location vop
:non-local-entry
))
213 (:temporary
(:sc unsigned-reg
:offset rcx-offset
:from
(:argument
2)) rcx
)
214 (:temporary
(:sc unsigned-reg
) loop-index temp
)
215 (:results
(result :scs
(any-reg))
216 (num :scs
(any-reg control-stack
)))
217 (:save-p
:force-to-stack
)
218 (:arg-refs top-tn-ref
)
221 ;; The 'top' arg contains the %esp value saved at the time the
222 ;; catch block was created and points to where the thrown values
224 (if (eq (tn-kind result
) :unused
)
228 (unless (eq (tn-kind num
) :unused
)
235 (inst sub loop-index n-word-bytes
)
236 (inst mov temp
(ea source loop-index
))
237 (inst mov
(ea result loop-index
) temp
)
239 (inst sub rcx
(fixnumize 1))
242 ;; Reset the CSP at last moved arg.
243 (inst lea rsp-tn
(ea result loop-index
))))
246 ;;; This VOP is just to force the TNs used in the cleanup onto the stack.
247 (define-vop (uwp-entry)
249 (:save-p
:force-to-stack
)
253 (note-this-location vop
:non-local-entry
)))
255 (define-vop (uwp-entry-block)
257 (:save-p
:force-to-stack
)
262 (note-this-location vop
:non-local-entry
)
263 ;; Get the saved block in UNWIND
264 (inst mov block
(ea (* 3 n-word-bytes
) rsp-tn
))))
266 (define-vop (unwind-to-frame-and-call)
267 (:args
(ofp :scs
(descriptor-reg))
268 (uwp :scs
(descriptor-reg))
269 (function :scs
(descriptor-reg) :to
:load
:target saved-function
)
270 (bsp :scs
(any-reg descriptor-reg
))
271 (catch-block :scs
(any-reg descriptor-reg
)))
272 (:arg-types system-area-pointer system-area-pointer t t t
)
273 (:temporary
(:sc sap-reg
) temp
)
274 (:temporary
(:sc descriptor-reg
:offset rbx-offset
) saved-function
)
275 (:temporary
(:sc unsigned-reg
:offset rax-offset
) block
)
276 (:temporary
(:sc unsigned-reg
:offset r11-offset
) extra-temp-reg
)
279 ;; Store the function into a non-stack location, since we'll be
280 ;; unwinding the stack and destroying register contents before we
281 ;; use it. It turns out that RBX is preserved as part of the
282 ;; normal multiple-value handling of an unwind, so use that.
283 (move saved-function function
)
285 ;; Allocate space for magic UWP block.
286 (inst sub rsp-tn
(* unwind-block-size n-word-bytes
))
287 ;; Set up magic catch / UWP block.
289 (loadw temp uwp sap-pointer-slot other-pointer-lowtag
)
290 (storew temp block unwind-block-uwp-slot
)
291 (loadw temp ofp sap-pointer-slot other-pointer-lowtag
)
292 (storew temp block unwind-block-cfp-slot
)
294 (inst lea extra-temp-reg
(rip-relative-ea entry-label
))
295 (storew extra-temp-reg block unwind-block-entry-pc-slot
)
296 (storew bsp block unwind-block-bsp-slot
)
297 (storew catch-block block unwind-block-current-catch-slot
)
299 ;; Run any required UWPs.
300 (invoke-asm-routine 'jmp
'unwind vop
)
303 ;; Move our saved function to where we want it now.
304 (move block saved-function
)
310 (inst lea rsp-tn
(ea (* (- sp-
>fp-offset
3) n-word-bytes
) rbp-tn
))
312 ;; Push the return-pc so it looks like we just called.
313 (pushw rbp-tn
(frame-word-offset return-pc-save-offset
))
316 (inst jmp
(ea (- (* closure-fun-slot n-word-bytes
) fun-pointer-lowtag
)