1 ;;;; the PPC 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 ocfp-offset
))
27 ;;; These VOPs are used in the reentered function to restore the
28 ;;; appropriate dynamic environment. Currently we only save the
29 ;;; CURRENT-CATCH and binding stack pointer. We don't need to
30 ;;; save/restore the current unwind-protect, since UNWIND-PROTECTs are
31 ;;; implicitly processed during unwinding. If there were any
32 ;;; 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-tl-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)))
51 #!+sb-thread
(:temporary
(:scs
(any-reg)) temp
)
54 (store-tl-symbol-value catch
*current-catch-block
* temp
)
55 (let ((cur-nfp (current-nfp-tn vop
)))
60 (define-vop (current-stack-pointer)
61 (:results
(res :scs
(any-reg descriptor-reg
)))
65 (define-vop (current-binding-pointer)
66 (:results
(res :scs
(any-reg descriptor-reg
)))
72 ;;;; Unwind block hackery:
74 ;;; Compute the address of the catch block from its TN, then store into the
75 ;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
77 (define-vop (make-unwind-block)
80 (:results
(block :scs
(any-reg)))
81 (:temporary
(:scs
(descriptor-reg)) temp
)
82 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
84 (inst addi block cfp-tn
(* (tn-offset tn
) n-word-bytes
))
85 (load-tl-symbol-value temp
*current-unwind-protect-block
*)
86 (storew temp block unwind-block-current-uwp-slot
)
87 (storew cfp-tn block unwind-block-current-cont-slot
)
88 (storew code-tn block unwind-block-current-code-slot
)
89 (inst compute-lra-from-code temp code-tn entry-label ndescr
)
90 (storew temp block catch-block-entry-pc-slot
)))
93 ;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
94 ;;; link the block into the Current-Catch list.
96 (define-vop (make-catch-block)
98 (tag :scs
(any-reg descriptor-reg
)))
100 (:results
(block :scs
(any-reg)))
101 (:temporary
(:scs
(descriptor-reg)) temp
)
102 (:temporary
(:scs
(descriptor-reg) :target block
:to
(:result
0)) result
)
103 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
105 (inst addi result cfp-tn
(* (tn-offset tn
) n-word-bytes
))
106 (load-tl-symbol-value temp
*current-unwind-protect-block
*)
107 (storew temp result catch-block-current-uwp-slot
)
108 (storew cfp-tn result catch-block-current-cont-slot
)
109 (storew code-tn result catch-block-current-code-slot
)
110 (inst compute-lra-from-code temp code-tn entry-label ndescr
)
111 (storew temp result catch-block-entry-pc-slot
)
113 (storew tag result catch-block-tag-slot
)
114 (load-tl-symbol-value temp
*current-catch-block
*)
115 (storew temp result catch-block-previous-catch-slot
)
116 (store-tl-symbol-value result
*current-catch-block
* temp
)
118 (move block result
)))
121 ;;; Just set the current unwind-protect to TN's address. This instantiates an
122 ;;; unwind block as an unwind-protect.
124 (define-vop (set-unwind-protect)
126 (:temporary
(:scs
(descriptor-reg)) new-uwp
)
127 #!+sb-thread
(:temporary
(:scs
(any-reg)) temp
)
129 (inst addi new-uwp cfp-tn
(* (tn-offset tn
) n-word-bytes
))
130 (store-tl-symbol-value new-uwp
*current-unwind-protect-block
* temp
)))
133 (define-vop (unlink-catch-block)
134 (:temporary
(:scs
(any-reg)) block
)
135 #!+sb-thread
(:temporary
(:scs
(any-reg)) temp
)
137 (:translate %catch-breakup
)
139 (load-tl-symbol-value block
*current-catch-block
*)
140 (loadw block block catch-block-previous-catch-slot
)
141 (store-tl-symbol-value block
*current-catch-block
* temp
)))
143 (define-vop (unlink-unwind-protect)
144 (:temporary
(:scs
(any-reg)) block
)
145 #!+sb-thread
(:temporary
(:scs
(any-reg)) temp
)
147 (:translate %unwind-protect-breakup
)
149 (load-tl-symbol-value block
*current-unwind-protect-block
*)
150 (loadw block block unwind-block-current-uwp-slot
)
151 (store-tl-symbol-value block
*current-unwind-protect-block
* temp
)))
157 (define-vop (nlx-entry)
158 (:args
(sp) ; Note: we can't list an sc-restriction, 'cause any load vops
159 ; would be inserted before the LRA.
162 (:results
(values :more t
))
163 (:temporary
(:scs
(descriptor-reg)) move-temp
)
165 (:save-p
:force-to-stack
)
168 (emit-return-pc label
)
169 (note-this-location vop
:non-local-entry
)
170 (cond ((zerop nvals
))
172 (let ((no-values (gen-label)))
174 (move (tn-ref-tn values
) null-tn
)
176 (loadw (tn-ref-tn values
) start
)
177 (emit-label no-values
)))
179 (collect ((defaults))
180 (inst addic. count count
(- (fixnumize 1)))
182 (tn-ref values
(tn-ref-across tn-ref
)))
184 (let ((default-lab (gen-label))
185 (tn (tn-ref-tn tn-ref
)))
186 (defaults (cons default-lab tn
))
188 (inst subi count count
(fixnumize 1))
189 (inst blt default-lab
)
191 ((descriptor-reg any-reg
)
194 (loadw move-temp start i
)
195 (store-stack-tn tn move-temp
)))
196 (inst cmpwi count
0)))
198 (let ((defaulting-done (gen-label)))
200 (emit-label defaulting-done
)
202 (assemble (*elsewhere
*)
203 (dolist (def (defaults))
204 (emit-label (car def
))
205 (let ((tn (cdr def
)))
207 ((descriptor-reg any-reg
)
210 (store-stack-tn tn null-tn
)))))
211 (inst b defaulting-done
))))))
212 (load-stack-tn csp-tn sp
)))
215 (define-vop (nlx-entry-multiple)
216 (:args
(top :target result
) (src) (count))
217 ;; Again, no SC restrictions for the args, 'cause the loading would
218 ;; happen before the entry label.
220 (:temporary
(:scs
(any-reg)) dst
)
221 (:temporary
(:scs
(descriptor-reg)) temp
)
222 (:results
(result :scs
(any-reg) :from
(:argument
0))
223 (num :scs
(any-reg) :from
(:argument
0)))
224 (:save-p
:force-to-stack
)
227 (emit-return-pc label
)
228 (note-this-location vop
:non-local-entry
)
229 (let ((loop (gen-label))
232 ;; Setup results, and test for the zero value case.
233 (load-stack-tn result top
)
238 ;; Compute dst as one slot down from result, because we inc the index
240 (inst subi dst result
4)
242 ;; Copy stuff down the stack.
244 (inst lwzx temp src num
)
245 (inst addi num num
(fixnumize 1))
246 (inst cmpw num count
)
247 (inst stwx temp dst num
)
252 (inst add csp-tn result num
))))
255 ;;; This VOP is just to force the TNs used in the cleanup onto the stack.
257 (define-vop (uwp-entry)
259 (:save-p
:force-to-stack
)
260 (:results
(block) (start) (count))
261 (:ignore block start count
)
264 (emit-return-pc label
)
265 (note-this-location vop
:non-local-entry
)))