3 ;;; Make an environment-live stack TN for saving the SP for NLX entry.
4 (!def-vm-support-routine make-nlx-sp-tn (env)
6 (make-representation-tn *fixnum-primitive-type* immediate-arg-scn)
9 ;;; Make a TN for the argument count passing location for a
11 (!def-vm-support-routine make-nlx-entry-arg-start-location ()
12 (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset))
14 ;;; Save and restore dynamic environment.
16 ;;; These VOPs are used in the reentered function to restore the appropriate
17 ;;; dynamic environment. Currently we only save the Current-Catch and binding
18 ;;; stack pointer. We don't need to save/restore the current unwind-protect,
19 ;;; since unwind-protects are implicitly processed during unwinding. If there
20 ;;; were any additional stacks, then this would be the place to restore the top
23 (define-vop (save-dynamic-state)
24 (:results (catch :scs (descriptor-reg))
25 (nfp :scs (descriptor-reg))
26 (nsp :scs (descriptor-reg)))
29 (load-symbol-value catch *current-catch-block*)
30 (let ((cur-nfp (current-nfp-tn vop)))
35 (define-vop (restore-dynamic-state)
36 (:args (catch :scs (descriptor-reg))
37 (nfp :scs (descriptor-reg))
38 (nsp :scs (descriptor-reg)))
41 (store-symbol-value catch *current-catch-block*)
42 (let ((cur-nfp (current-nfp-tn vop)))
47 (define-vop (current-stack-pointer)
48 (:results (res :scs (any-reg descriptor-reg)))
52 (define-vop (current-binding-pointer)
53 (:results (res :scs (any-reg descriptor-reg)))
58 ;;;; Unwind block hackery:
60 ;;; Compute the address of the catch block from its TN, then store into the
61 ;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
63 (define-vop (make-unwind-block)
66 (:results (block :scs (any-reg)))
67 (:temporary (:scs (descriptor-reg)) temp)
68 (:temporary (:scs (non-descriptor-reg)) ndescr)
70 (inst addi (* (tn-offset tn) n-word-bytes) cfp-tn block)
71 (load-symbol-value temp *current-unwind-protect-block*)
72 (storew temp block unwind-block-current-uwp-slot)
73 (storew cfp-tn block unwind-block-current-cont-slot)
74 (storew code-tn block unwind-block-current-code-slot)
75 (inst compute-lra-from-code code-tn entry-label ndescr temp)
76 (storew temp block catch-block-entry-pc-slot)))
78 ;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
79 ;;; link the block into the Current-Catch list.
81 (define-vop (make-catch-block)
83 (tag :scs (any-reg descriptor-reg)))
85 (:results (block :scs (any-reg)))
86 (:temporary (:scs (descriptor-reg)) temp)
87 (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result)
88 (:temporary (:scs (non-descriptor-reg)) ndescr)
90 (inst addi (* (tn-offset tn) n-word-bytes) cfp-tn result)
91 (load-symbol-value temp *current-unwind-protect-block*)
92 (storew temp result catch-block-current-uwp-slot)
93 (storew cfp-tn result catch-block-current-cont-slot)
94 (storew code-tn result catch-block-current-code-slot)
95 (inst compute-lra-from-code code-tn entry-label ndescr temp)
96 (storew temp result catch-block-entry-pc-slot)
98 (storew tag result catch-block-tag-slot)
99 (load-symbol-value temp *current-catch-block*)
100 (storew temp result catch-block-previous-catch-slot)
101 (store-symbol-value result *current-catch-block*)
102 (move result block)))
104 ;;; Just set the current unwind-protect to TN's address. This instantiates an
105 ;;; unwind block as an unwind-protect.
107 (define-vop (set-unwind-protect)
109 (:temporary (:scs (descriptor-reg)) new-uwp)
111 (inst addi (* (tn-offset tn) n-word-bytes) cfp-tn new-uwp)
112 (store-symbol-value new-uwp *current-unwind-protect-block*)))
115 (define-vop (unlink-catch-block)
116 (:temporary (:scs (any-reg)) block)
118 (:translate %catch-breakup)
120 (load-symbol-value block *current-catch-block*)
121 (loadw block block catch-block-previous-catch-slot)
122 (store-symbol-value block *current-catch-block*)))
124 (define-vop (unlink-unwind-protect)
125 (:temporary (:scs (any-reg)) block)
127 (:translate %unwind-protect-breakup)
129 (load-symbol-value block *current-unwind-protect-block*)
130 (loadw block block unwind-block-current-uwp-slot)
131 (store-symbol-value block *current-unwind-protect-block*)))
137 (define-vop (nlx-entry)
138 (:args (sp) ;; Note: we can't list an sc-restriction, 'cause any load vops
139 ;; would be inserted before the LRA.
142 (:results (values :more t))
143 (:temporary (:scs (descriptor-reg)) move-temp)
145 (:save-p :force-to-stack)
148 (emit-return-pc label)
149 (note-this-location vop :non-local-entry)
150 (cond ((zerop nvals))
152 (loadw (tn-ref-tn values) start)
153 (inst comclr count zero-tn zero-tn :<>)
154 (move null-tn (tn-ref-tn values) t))
156 (collect ((defaults))
158 (tn-ref values (tn-ref-across tn-ref)))
160 (let ((default-lab (gen-label))
161 (tn (tn-ref-tn tn-ref)))
162 (defaults (cons default-lab tn))
163 (inst comb := zero-tn count default-lab)
164 (inst addi (fixnumize -1) count count)
166 ((descriptor-reg any-reg)
169 (loadw move-temp start i)
170 (store-stack-tn 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 (let ((tn (cdr def)))
178 ((descriptor-reg any-reg)
181 (store-stack-tn tn null-tn)))))
182 (inst b defaulting-done :nullify t))))))
183 (load-stack-tn csp-tn sp)))
186 (define-vop (nlx-entry-multiple)
187 (:args (top :target dst) (start :target src) (count :target num))
188 ;; Again, no SC restrictions for the args, 'cause the loading would
189 ;; happen before the entry label.
191 (:temporary (:scs (any-reg) :from (:argument 0)) dst)
192 (:temporary (:scs (any-reg) :from (:argument 1)) src)
193 (:temporary (:scs (any-reg) :from (:argument 2)) num)
194 (:temporary (:scs (descriptor-reg)) temp)
195 (:results (new-start) (new-count))
196 (:save-p :force-to-stack)
199 (emit-return-pc label)
200 (note-this-location vop :non-local-entry)
201 (let ((loop (gen-label))
205 (load-stack-tn dst top)
209 ;; Establish results.
211 (any-reg (move dst new-start))
212 (control-stack (store-stack-tn new-start dst)))
213 (inst comb := num zero-tn done :nullify t)
215 (any-reg (move num new-count))
216 (control-stack (store-stack-tn new-count num)))
218 ;; Copy stuff on stack.
220 (inst ldwm n-word-bytes src temp)
221 (inst addib :<> (fixnumize -1) num loop)
222 (inst stwm temp n-word-bytes dst)
227 ;;; This VOP is just to force the TNs used in the cleanup onto the stack.
229 (define-vop (uwp-entry)
231 (:save-p :force-to-stack)
232 (:results (block) (start) (count))
233 (:ignore block start count)
236 (emit-return-pc label)
237 (note-this-location vop :non-local-entry)))