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)
19 (aver (sc-is tn catch-block
))
20 (make-ea :qword
:base rbp-tn
21 :disp
(frame-byte-offset (+ -
1 (tn-offset tn
) catch-block-size
))))
24 ;;;; Save and restore dynamic environment.
26 ;;;; These VOPs are used in the reentered function to restore the
27 ;;;; appropriate dynamic environment. Currently we only save the
28 ;;;; Current-Catch. (Before sbcl-0.7.0,
29 ;;;; when there were IR1 and byte interpreters, we had to save
30 ;;;; the interpreter "eval stack" too.)
32 ;;;; We don't need to save/restore the current UNWIND-PROTECT, since
33 ;;;; UNWIND-PROTECTs are implicitly processed during unwinding.
35 ;;;; We don't need to save the BSP, because that is handled automatically.
37 (define-vop (save-dynamic-state)
38 (:results
(catch :scs
(descriptor-reg)))
40 (load-tl-symbol-value catch
*current-catch-block
*)))
42 (define-vop (restore-dynamic-state)
43 (:args
(catch :scs
(descriptor-reg)))
45 (store-tl-symbol-value catch
*current-catch-block
*)))
47 (define-vop (current-stack-pointer)
48 (:results
(res :scs
(any-reg control-stack
)))
52 (define-vop (current-binding-pointer)
53 (:results
(res :scs
(any-reg descriptor-reg
)))
55 (load-binding-stack-pointer res
)))
57 ;;;; unwind block hackery
59 ;;; Compute the address of the catch block from its TN, then store into the
60 ;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
61 (define-vop (make-unwind-block)
64 (:temporary
(:sc unsigned-reg
) temp
)
65 (:results
(block :scs
(any-reg)))
67 (inst lea block
(catch-block-ea tn
))
68 (load-tl-symbol-value temp
*current-unwind-protect-block
*)
69 (storew temp block unwind-block-current-uwp-slot
)
70 (storew rbp-tn block unwind-block-current-cont-slot
)
71 (inst lea temp
(make-fixup nil
:code-object entry-label
))
72 (storew temp block unwind-block-entry-pc-slot
)))
74 ;;; like MAKE-UNWIND-BLOCK, except that we also store in the specified
75 ;;; tag, and link the block into the CURRENT-CATCH list
76 (define-vop (make-catch-block)
78 (tag :scs
(any-reg descriptor-reg
) :to
(:result
1)))
80 (:results
(block :scs
(any-reg)))
81 (:temporary
(:sc descriptor-reg
) temp
)
83 (inst lea block
(catch-block-ea tn
))
84 (load-tl-symbol-value temp
*current-unwind-protect-block
*)
85 (storew temp block catch-block-current-uwp-slot
)
86 (storew rbp-tn block catch-block-current-cont-slot
)
87 (inst lea temp
(make-fixup nil
:code-object entry-label
))
88 (storew temp block catch-block-entry-pc-slot
)
89 (storew tag block catch-block-tag-slot
)
90 (load-tl-symbol-value temp
*current-catch-block
*)
91 (storew temp block catch-block-previous-catch-slot
)
92 (store-tl-symbol-value block
*current-catch-block
*)))
94 ;;; Just set the current unwind-protect to TN's address. This instantiates an
95 ;;; unwind block as an unwind-protect.
96 (define-vop (set-unwind-protect)
98 (:temporary
(:sc unsigned-reg
) new-uwp
)
100 (inst lea new-uwp
(catch-block-ea tn
))
101 (store-tl-symbol-value new-uwp
*current-unwind-protect-block
*)))
103 (define-vop (unlink-catch-block)
104 (:temporary
(:sc unsigned-reg
) block
)
106 (:translate %catch-breakup
)
108 (load-tl-symbol-value block
*current-catch-block
*)
109 (loadw block block catch-block-previous-catch-slot
)
110 (store-tl-symbol-value block
*current-catch-block
*)))
112 (define-vop (unlink-unwind-protect)
113 (:temporary
(:sc unsigned-reg
) block
)
115 (:translate %unwind-protect-breakup
)
117 (load-tl-symbol-value block
*current-unwind-protect-block
*)
118 (loadw block block unwind-block-current-uwp-slot
)
119 (store-tl-symbol-value block
*current-unwind-protect-block
*)))
122 (define-vop (nlx-entry)
123 ;; Note: we can't list an sc-restriction, 'cause any load vops would
124 ;; be inserted before the return-pc label.
128 (:results
(values :more t
))
129 (:temporary
(:sc descriptor-reg
) move-temp
)
131 (:save-p
:force-to-stack
)
135 (note-this-location vop
:non-local-entry
)
136 (cond ((zerop nvals
))
138 (let ((no-values (gen-label)))
139 (inst mov
(tn-ref-tn values
) nil-value
)
140 (inst jrcxz no-values
)
141 (loadw (tn-ref-tn values
) start -
1)
142 (emit-label no-values
)))
144 ;; FIXME: this is mostly copied from
145 ;; DEFAULT-UNKNOWN-VALUES.
146 (collect ((defaults))
148 (tn-ref values
(tn-ref-across tn-ref
)))
150 (let ((default-lab (gen-label))
151 (tn (tn-ref-tn tn-ref
))
152 (first-stack-arg-p (= i register-arg-count
)))
153 (defaults (cons default-lab
(cons tn first-stack-arg-p
)))
154 (inst cmp count
(fixnumize i
))
155 (inst jmp
:le default-lab
)
156 (when first-stack-arg-p
157 (storew rdx-tn rbx-tn -
1))
159 ((descriptor-reg any-reg
)
160 (loadw tn start
(frame-word-offset (+ sp-
>fp-offset i
))))
162 (loadw move-temp start
163 (frame-word-offset (+ sp-
>fp-offset i
)))
164 (inst mov tn move-temp
)))))
165 (let ((defaulting-done (gen-label)))
166 (emit-label defaulting-done
)
167 (assemble (*elsewhere
*)
168 (dolist (default (defaults))
169 (emit-label (car default
))
172 (inst mov
(second default
) nil-value
))
173 (inst jmp defaulting-done
))))))
174 (inst mov rsp-tn sp
)))
176 (define-vop (nlx-entry-multiple)
180 ;; Again, no SC restrictions for the args, 'cause the loading would
181 ;; happen before the entry label.
183 (:temporary
(:sc unsigned-reg
:offset rcx-offset
:from
(:argument
2)) rcx
)
184 (:temporary
(:sc unsigned-reg
:offset rsi-offset
) rsi
)
185 (:temporary
(:sc unsigned-reg
:offset rdi-offset
) rdi
)
186 (:results
(result :scs
(any-reg) :from
(:argument
0))
187 (num :scs
(any-reg control-stack
)))
188 (:save-p
:force-to-stack
)
192 (note-this-location vop
:non-local-entry
)
194 (inst lea rsi
(make-ea :qword
:base source
:disp
(- n-word-bytes
)))
195 ;; The 'top' arg contains the %esp value saved at the time the
196 ;; catch block was created and points to where the thrown values
201 (inst sub rdi n-word-bytes
)
202 (move rcx count
) ; fixnum words == bytes
204 (inst shr rcx n-fixnum-tag-bits
) ; word count for <rep movs>
205 ;; If we got zero, we be done.
213 ;; Reset the CSP at last moved arg.
214 (inst lea rsp-tn
(make-ea :qword
:base rdi
:disp n-word-bytes
))))
217 ;;; This VOP is just to force the TNs used in the cleanup onto the stack.
218 (define-vop (uwp-entry)
220 (:save-p
:force-to-stack
)
221 (:results
(block) (start) (count))
222 (:ignore block start count
)
226 (note-this-location vop
:non-local-entry
)))
228 (define-vop (unwind-to-frame-and-call)
229 (:args
(ofp :scs
(descriptor-reg))
230 (uwp :scs
(descriptor-reg))
231 (function :scs
(descriptor-reg) :to
:load
:target saved-function
))
232 (:arg-types system-area-pointer system-area-pointer t
)
233 (:temporary
(:sc sap-reg
) temp
)
234 (:temporary
(:sc descriptor-reg
:offset rbx-offset
) saved-function
)
235 (:temporary
(:sc unsigned-reg
:offset rax-offset
) block
)
237 ;; Store the function into a non-stack location, since we'll be
238 ;; unwinding the stack and destroying register contents before we
239 ;; use it. It turns out that RBX is preserved as part of the
240 ;; normal multiple-value handling of an unwind, so use that.
241 (move saved-function function
)
243 ;; Allocate space for magic UWP block.
244 (inst sub rsp-tn
(* unwind-block-size n-word-bytes
))
245 ;; Set up magic catch / UWP block.
247 (loadw temp uwp sap-pointer-slot other-pointer-lowtag
)
248 (storew temp block unwind-block-current-uwp-slot
)
249 (loadw temp ofp sap-pointer-slot other-pointer-lowtag
)
250 (storew temp block unwind-block-current-cont-slot
)
252 (inst lea temp-reg-tn
(make-fixup nil
:code-object entry-label
))
253 (storew temp-reg-tn block unwind-block-entry-pc-slot
)
255 ;; Run any required UWPs.
256 (inst mov temp-reg-tn
(make-fixup 'unwind
:assembly-routine
))
257 (inst jmp temp-reg-tn
)
260 ;; Move our saved function to where we want it now.
261 (move block saved-function
)
268 (make-ea :qword
:base rbp-tn
269 :disp
(* (- sp-
>fp-offset
3) n-word-bytes
)))
271 ;; Push the return-pc so it looks like we just called.
272 (pushw rbp-tn
(frame-word-offset return-pc-save-offset
))
275 (inst jmp
(make-ea :qword
:base block
276 :disp
(- (* closure-fun-slot n-word-bytes
)
277 fun-pointer-lowtag
)))))