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 an environment-live stack TN for saving the SP for NLX entry.
15 (!def-vm-support-routine make-nlx-sp-tn
(env)
17 (make-representation-tn *fixnum-primitive-type
* any-reg-sc-number
)
20 ;;; Make a TN for the argument count passing location for a non-local entry.
21 (!def-vm-support-routine make-nlx-entry-arg-start-location
()
22 (make-wired-tn *fixnum-primitive-type
* any-reg-sc-number rbx-offset
))
24 (defun catch-block-ea (tn)
25 (aver (sc-is tn catch-block
))
26 (make-ea :qword
:base rbp-tn
27 :disp
(- (* (+ (tn-offset tn
) catch-block-size
) n-word-bytes
))))
30 ;;;; Save and restore dynamic environment.
32 ;;;; These VOPs are used in the reentered function to restore the
33 ;;;; appropriate dynamic environment. Currently we only save the
34 ;;;; Current-Catch and the alien stack pointer. (Before sbcl-0.7.0,
35 ;;;; when there were IR1 and byte interpreters, we had to save
36 ;;;; the interpreter "eval stack" too.)
38 ;;;; We don't need to save/restore the current UNWIND-PROTECT, since
39 ;;;; UNWIND-PROTECTs are implicitly processed during unwinding.
41 ;;;; We don't need to save the BSP, because that is handled automatically.
43 (define-vop (save-dynamic-state)
44 (:results
(catch :scs
(descriptor-reg))
45 (alien-stack :scs
(descriptor-reg)))
47 (load-tl-symbol-value catch
*current-catch-block
*)
48 (load-tl-symbol-value alien-stack
*alien-stack
*)))
50 (define-vop (restore-dynamic-state)
51 (:args
(catch :scs
(descriptor-reg))
52 (alien-stack :scs
(descriptor-reg)))
53 #!+sb-thread
(:temporary
(:sc unsigned-reg
) temp
)
55 (store-tl-symbol-value catch
*current-catch-block
* temp
)
56 (store-tl-symbol-value alien-stack
*alien-stack
* temp
)))
58 (define-vop (current-stack-pointer)
59 (:results
(res :scs
(any-reg control-stack
)))
63 (define-vop (current-binding-pointer)
64 (:results
(res :scs
(any-reg descriptor-reg
)))
66 (load-binding-stack-pointer res
)))
68 ;;;; unwind block hackery
70 ;;; Compute the address of the catch block from its TN, then store into the
71 ;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
72 (define-vop (make-unwind-block)
75 (:temporary
(:sc unsigned-reg
) temp
)
76 (:results
(block :scs
(any-reg)))
78 (inst lea block
(catch-block-ea tn
))
79 (load-tl-symbol-value temp
*current-unwind-protect-block
*)
80 (storew temp block unwind-block-current-uwp-slot
)
81 (storew rbp-tn block unwind-block-current-cont-slot
)
82 (inst lea temp
(make-fixup nil
:code-object entry-label
))
83 (storew temp block catch-block-entry-pc-slot
)))
85 ;;; like MAKE-UNWIND-BLOCK, except that we also store in the specified
86 ;;; tag, and link the block into the CURRENT-CATCH list
87 (define-vop (make-catch-block)
89 (tag :scs
(any-reg descriptor-reg
) :to
(:result
1)))
91 (:results
(block :scs
(any-reg)))
92 (:temporary
(:sc descriptor-reg
) temp
)
94 (inst lea block
(catch-block-ea tn
))
95 (load-tl-symbol-value temp
*current-unwind-protect-block
*)
96 (storew temp block unwind-block-current-uwp-slot
)
97 (storew rbp-tn block unwind-block-current-cont-slot
)
98 (inst lea temp
(make-fixup nil
:code-object entry-label
))
99 (storew temp block catch-block-entry-pc-slot
)
100 (storew tag block catch-block-tag-slot
)
101 (load-tl-symbol-value temp
*current-catch-block
*)
102 (storew temp block catch-block-previous-catch-slot
)
103 (store-tl-symbol-value block
*current-catch-block
* temp
)))
105 ;;; Just set the current unwind-protect to TN's address. This instantiates an
106 ;;; unwind block as an unwind-protect.
107 (define-vop (set-unwind-protect)
109 (:temporary
(:sc unsigned-reg
) new-uwp
#!+sb-thread tls
)
111 (inst lea new-uwp
(catch-block-ea tn
))
112 (store-tl-symbol-value new-uwp
*current-unwind-protect-block
* tls
)))
114 (define-vop (unlink-catch-block)
115 (:temporary
(:sc unsigned-reg
) #!+sb-thread tls block
)
117 (:translate %catch-breakup
)
119 (load-tl-symbol-value block
*current-catch-block
*)
120 (loadw block block catch-block-previous-catch-slot
)
121 (store-tl-symbol-value block
*current-catch-block
* tls
)))
123 (define-vop (unlink-unwind-protect)
124 (:temporary
(:sc unsigned-reg
) block
#!+sb-thread tls
)
126 (:translate %unwind-protect-breakup
)
128 (load-tl-symbol-value block
*current-unwind-protect-block
*)
129 (loadw block block unwind-block-current-uwp-slot
)
130 (store-tl-symbol-value block
*current-unwind-protect-block
* tls
)))
133 (define-vop (nlx-entry)
134 ;; Note: we can't list an sc-restriction, 'cause any load vops would
135 ;; be inserted before the return-pc label.
139 (:results
(values :more t
))
140 (:temporary
(:sc descriptor-reg
) move-temp
)
142 (:save-p
:force-to-stack
)
146 (note-this-location vop
:non-local-entry
)
147 (cond ((zerop nvals
))
149 (let ((no-values (gen-label)))
150 (inst mov
(tn-ref-tn values
) nil-value
)
151 (inst jrcxz no-values
)
152 (loadw (tn-ref-tn values
) start -
1)
153 (emit-label no-values
)))
155 (collect ((defaults))
157 (tn-ref values
(tn-ref-across tn-ref
)))
159 (let ((default-lab (gen-label))
160 (tn (tn-ref-tn tn-ref
)))
161 (defaults (cons default-lab tn
))
163 (inst cmp count
(fixnumize i
))
164 (inst jmp
:le default-lab
)
166 ((descriptor-reg any-reg
)
167 (loadw tn start
(- (1+ i
))))
169 (loadw move-temp start
(- (1+ i
)))
170 (inst mov tn move-temp
)))))
171 (let ((defaulting-done (gen-label)))
172 (emit-label defaulting-done
)
173 (assemble (*elsewhere
*)
174 (dolist (def (defaults))
175 (emit-label (car def
))
176 (inst mov
(cdr def
) nil-value
))
177 (inst jmp defaulting-done
))))))
178 (inst mov rsp-tn sp
)))
180 (define-vop (nlx-entry-multiple)
184 ;; Again, no SC restrictions for the args, 'cause the loading would
185 ;; happen before the entry label.
187 (:temporary
(:sc unsigned-reg
:offset rcx-offset
:from
(:argument
2)) rcx
)
188 (:temporary
(:sc unsigned-reg
:offset rsi-offset
) rsi
)
189 (:temporary
(:sc unsigned-reg
:offset rdi-offset
) rdi
)
190 (:results
(result :scs
(any-reg) :from
(:argument
0))
191 (num :scs
(any-reg control-stack
)))
192 (:save-p
:force-to-stack
)
196 (note-this-location vop
:non-local-entry
)
198 (inst lea rsi
(make-ea :qword
:base source
:disp
(- n-word-bytes
)))
199 ;; The 'top' arg contains the %esp value saved at the time the
200 ;; catch block was created and points to where the thrown values
205 (inst sub rdi n-word-bytes
)
206 (move rcx count
) ; fixnum words == bytes
208 (inst shr rcx word-shift
) ; word count for <rep movs>
209 ;; If we got zero, we be done.
217 ;; Reset the CSP at last moved arg.
218 (inst lea rsp-tn
(make-ea :qword
:base rdi
:disp n-word-bytes
))))
221 ;;; 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
)
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)))
236 (:arg-types system-area-pointer system-area-pointer t
)
237 (:temporary
(:sc sap-reg
) temp
)
238 (:temporary
(:sc unsigned-reg
:offset rax-offset
) block
)
240 ;; Store the function into a non-stack location, since we'll be
241 ;; unwinding the stack and destroying register contents before we
243 (store-tl-symbol-value function
244 *unwind-to-frame-function
*
247 ;; Allocate space for magic UWP block.
248 (inst sub rsp-tn unwind-block-size
)
249 ;; Set up magic catch / UWP block.
251 (loadw temp uwp sap-pointer-slot other-pointer-lowtag
)
252 (storew temp block unwind-block-current-uwp-slot
)
253 (loadw temp ofp sap-pointer-slot other-pointer-lowtag
)
254 (storew temp block unwind-block-current-cont-slot
)
256 (inst lea temp-reg-tn
(make-fixup nil
:code-object entry-label
))
259 catch-block-entry-pc-slot
)
261 ;; Run any required UWPs.
262 (inst lea temp-reg-tn
(make-fixup 'unwind
:assembly-routine
))
263 (inst jmp temp-reg-tn
)
266 ;; Load function from symbol
267 (load-tl-symbol-value block
*unwind-to-frame-function
*)
274 (make-ea :qword
:base rbp-tn
:disp
(* -
3 n-word-bytes
)))
276 ;; Push the return-pc so it looks like we just called.
280 (inst jmp
(make-ea :qword
:base block
281 :disp
(- (* closure-fun-slot n-word-bytes
)
282 fun-pointer-lowtag
)))))