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 a TN for the argument count passing location for a
17 (defun make-nlx-entry-arg-start-location ()
18 (make-wired-tn *fixnum-primitive-type
* immediate-arg-scn ocfp-offset
))
21 ;;; These VOPs are used in the reentered function to restore the
22 ;;; appropriate dynamic environment. Currently we only save the
23 ;;; CURRENT-CATCH and binding stack pointer. We don't need to
24 ;;; save/restore the current unwind-protect, since UNWIND-PROTECTs are
25 ;;; implicitly processed during unwinding. If there were any
26 ;;; additional stacks, then this would be the place to restore the top
29 (define-vop (save-dynamic-state)
30 (:results
(catch :scs
(descriptor-reg))
31 (nfp :scs
(descriptor-reg))
32 (nsp :scs
(descriptor-reg)))
35 (load-tl-symbol-value catch
*current-catch-block
*)
36 (let ((cur-nfp (current-nfp-tn vop
)))
41 (define-vop (restore-dynamic-state)
42 (:args
(catch :scs
(descriptor-reg))
43 (nfp :scs
(descriptor-reg))
44 (nsp :scs
(descriptor-reg)))
45 #!+sb-thread
(:temporary
(:scs
(any-reg)) temp
)
48 (store-tl-symbol-value catch
*current-catch-block
* temp
)
49 (let ((cur-nfp (current-nfp-tn vop
)))
54 (define-vop (current-stack-pointer)
55 (:results
(res :scs
(any-reg descriptor-reg
)))
59 (define-vop (current-binding-pointer)
60 (:results
(res :scs
(any-reg descriptor-reg
)))
66 ;;;; Unwind block hackery:
68 ;;; Compute the address of the catch block from its TN, then store into the
69 ;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
71 (define-vop (make-unwind-block)
74 (:results
(block :scs
(any-reg)))
75 (:temporary
(:scs
(descriptor-reg)) temp
)
76 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
78 (inst addi block cfp-tn
(* (tn-offset tn
) n-word-bytes
))
79 (load-tl-symbol-value temp
*current-unwind-protect-block
*)
80 (storew temp block unwind-block-current-uwp-slot
)
81 (storew cfp-tn block unwind-block-current-cont-slot
)
82 (storew code-tn block unwind-block-current-code-slot
)
83 (inst compute-lra-from-code temp code-tn entry-label ndescr
)
84 (storew temp block catch-block-entry-pc-slot
)))
87 ;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
88 ;;; link the block into the Current-Catch list.
90 (define-vop (make-catch-block)
92 (tag :scs
(any-reg descriptor-reg
)))
94 (:results
(block :scs
(any-reg)))
95 (:temporary
(:scs
(descriptor-reg)) temp
)
96 (:temporary
(:scs
(descriptor-reg) :target block
:to
(:result
0)) result
)
97 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
99 (inst addi result cfp-tn
(* (tn-offset tn
) n-word-bytes
))
100 (load-tl-symbol-value temp
*current-unwind-protect-block
*)
101 (storew temp result catch-block-current-uwp-slot
)
102 (storew cfp-tn result catch-block-current-cont-slot
)
103 (storew code-tn result catch-block-current-code-slot
)
104 (inst compute-lra-from-code temp code-tn entry-label ndescr
)
105 (storew temp result catch-block-entry-pc-slot
)
107 (storew tag result catch-block-tag-slot
)
108 (load-tl-symbol-value temp
*current-catch-block
*)
109 (storew temp result catch-block-previous-catch-slot
)
110 (store-tl-symbol-value result
*current-catch-block
* temp
)
112 (move block result
)))
115 ;;; Just set the current unwind-protect to TN's address. This instantiates an
116 ;;; unwind block as an unwind-protect.
118 (define-vop (set-unwind-protect)
120 (:temporary
(:scs
(descriptor-reg)) new-uwp
)
121 #!+sb-thread
(:temporary
(:scs
(any-reg)) temp
)
123 (inst addi new-uwp cfp-tn
(* (tn-offset tn
) n-word-bytes
))
124 (store-tl-symbol-value new-uwp
*current-unwind-protect-block
* temp
)))
127 (define-vop (unlink-catch-block)
128 (:temporary
(:scs
(any-reg)) block
)
129 #!+sb-thread
(:temporary
(:scs
(any-reg)) temp
)
131 (:translate %catch-breakup
)
133 (load-tl-symbol-value block
*current-catch-block
*)
134 (loadw block block catch-block-previous-catch-slot
)
135 (store-tl-symbol-value block
*current-catch-block
* temp
)))
137 (define-vop (unlink-unwind-protect)
138 (:temporary
(:scs
(any-reg)) block
)
139 #!+sb-thread
(:temporary
(:scs
(any-reg)) temp
)
141 (:translate %unwind-protect-breakup
)
143 (load-tl-symbol-value block
*current-unwind-protect-block
*)
144 (loadw block block unwind-block-current-uwp-slot
)
145 (store-tl-symbol-value block
*current-unwind-protect-block
* temp
)))
151 (define-vop (nlx-entry)
152 (:args
(sp) ; Note: we can't list an sc-restriction, 'cause any load vops
153 ; would be inserted before the LRA.
156 (:results
(values :more t
))
157 (:temporary
(:scs
(descriptor-reg)) move-temp
)
159 (:save-p
:force-to-stack
)
162 (emit-return-pc label
)
163 (note-this-location vop
:non-local-entry
)
164 (cond ((zerop nvals
))
166 (let ((no-values (gen-label)))
168 (move (tn-ref-tn values
) null-tn
)
170 (loadw (tn-ref-tn values
) start
)
171 (emit-label no-values
)))
173 (collect ((defaults))
174 (inst addic. count count
(- (fixnumize 1)))
176 (tn-ref values
(tn-ref-across tn-ref
)))
178 (let ((default-lab (gen-label))
179 (tn (tn-ref-tn tn-ref
)))
180 (defaults (cons default-lab tn
))
182 (inst subi count count
(fixnumize 1))
183 (inst blt default-lab
)
185 ((descriptor-reg any-reg
)
188 (loadw move-temp start i
)
189 (store-stack-tn tn move-temp
)))
190 (inst cmpwi count
0)))
192 (let ((defaulting-done (gen-label)))
194 (emit-label defaulting-done
)
196 (assemble (*elsewhere
*)
197 (dolist (def (defaults))
198 (emit-label (car def
))
199 (let ((tn (cdr def
)))
201 ((descriptor-reg any-reg
)
204 (store-stack-tn tn null-tn
)))))
205 (inst b defaulting-done
))))))
206 (load-stack-tn csp-tn sp
)))
209 (define-vop (nlx-entry-multiple)
210 (:args
(top :target result
) (src) (count))
211 ;; Again, no SC restrictions for the args, 'cause the loading would
212 ;; happen before the entry label.
214 (:temporary
(:scs
(any-reg)) dst
)
215 (:temporary
(:scs
(descriptor-reg)) temp
)
216 (:results
(result :scs
(any-reg) :from
(:argument
0))
217 (num :scs
(any-reg) :from
(:argument
0)))
218 (:save-p
:force-to-stack
)
221 (emit-return-pc label
)
222 (note-this-location vop
:non-local-entry
)
223 (let ((loop (gen-label))
226 ;; Setup results, and test for the zero value case.
227 (load-stack-tn result top
)
232 ;; Compute dst as one slot down from result, because we inc the index
234 (inst subi dst result
4)
236 ;; Copy stuff down the stack.
238 (inst lwzx temp src num
)
239 (inst addi num num
(fixnumize 1))
240 (inst cmpw num count
)
241 (inst stwx temp dst num
)
246 (inst add csp-tn result num
))))
249 ;;; This VOP is just to force the TNs used in the cleanup onto the stack.
251 (define-vop (uwp-entry)
253 (:save-p
:force-to-stack
)
254 (:results
(block) (start) (count))
255 (:ignore block start count
)
258 (emit-return-pc label
)
259 (note-this-location vop
:non-local-entry
)))