3 ;;; MAKE-NLX-SP-TN -- Interface
5 ;;; Make an environment-live stack TN for saving the SP for NLX entry.
7 (!def-vm-support-routine make-nlx-sp-tn (env)
9 (make-representation-tn *fixnum-primitive-type* immediate-arg-scn)
12 ;;; Make-NLX-Entry-Argument-Start-Location -- Interface
14 ;;; Make a TN for the argument count passing location for a
17 (!def-vm-support-routine make-nlx-entry-arg-start-location ()
18 (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset))
21 ;;; Save and restore dynamic environment.
23 ;;; These VOPs are used in the reentered function to restore the appropriate
24 ;;; dynamic environment. Currently we only save the Current-Catch and binding
25 ;;; stack pointer. We don't need to save/restore the current unwind-protect,
26 ;;; since unwind-protects are implicitly processed during unwinding. If there
27 ;;; were any additional stacks, then this would be the place to restore the top
31 ;;; Make-Dynamic-State-TNs -- Interface
33 ;;; Return a list of TNs that can be used to snapshot the dynamic state for
34 ;;; use with the Save/Restore-Dynamic-Environment VOPs.
36 (!def-vm-support-routine make-dynamic-state-tns ()
37 (make-n-tns 4 *backend-t-primitive-type*))
39 (define-vop (save-dynamic-state)
40 (:results (catch :scs (descriptor-reg))
41 (nfp :scs (descriptor-reg))
42 (nsp :scs (descriptor-reg)))
45 (load-symbol-value catch *current-catch-block*)
46 (let ((cur-nfp (current-nfp-tn vop)))
51 (define-vop (restore-dynamic-state)
52 (:args (catch :scs (descriptor-reg))
53 (nfp :scs (descriptor-reg))
54 (nsp :scs (descriptor-reg)))
57 (store-symbol-value catch *current-catch-block*)
58 (let ((cur-nfp (current-nfp-tn vop)))
63 (define-vop (current-stack-pointer)
64 (:results (res :scs (any-reg descriptor-reg)))
68 (define-vop (current-binding-pointer)
69 (:results (res :scs (any-reg descriptor-reg)))
74 ;;;; Unwind block hackery:
76 ;;; Compute the address of the catch block from its TN, then store into the
77 ;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
79 (define-vop (make-unwind-block)
82 (:results (block :scs (any-reg)))
83 (:temporary (:scs (descriptor-reg)) temp)
84 (:temporary (:scs (non-descriptor-reg)) ndescr)
86 (inst addi (* (tn-offset tn) n-word-bytes) cfp-tn block)
87 (load-symbol-value temp *current-unwind-protect-block*)
88 (storew temp block unwind-block-current-uwp-slot)
89 (storew cfp-tn block unwind-block-current-cont-slot)
90 (storew code-tn block unwind-block-current-code-slot)
91 (inst compute-lra-from-code code-tn entry-label ndescr temp)
92 (storew temp block catch-block-entry-pc-slot)))
94 ;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
95 ;;; link the block into the Current-Catch list.
97 (define-vop (make-catch-block)
99 (tag :scs (descriptor-reg)))
101 (:results (block :scs (any-reg) :from (:argument 0)))
102 (:temporary (:scs (descriptor-reg)) temp)
103 (:temporary (:scs (non-descriptor-reg)) ndescr)
105 (inst addi (* (tn-offset tn) n-word-bytes) cfp-tn block)
106 (load-symbol-value temp *current-unwind-protect-block*)
107 (storew temp block catch-block-current-uwp-slot)
108 (storew cfp-tn block catch-block-current-cont-slot)
109 (storew code-tn block catch-block-current-code-slot)
110 (inst compute-lra-from-code code-tn entry-label ndescr temp)
111 (storew temp block catch-block-entry-pc-slot)
113 (storew tag block catch-block-tag-slot)
114 (load-symbol-value temp *current-catch-block*)
115 (storew temp block catch-block-previous-catch-slot)
116 (store-symbol-value block *current-catch-block*)))
119 ;;; Just set the current unwind-protect to TN's address. This instantiates an
120 ;;; unwind block as an unwind-protect.
122 (define-vop (set-unwind-protect)
124 (:temporary (:scs (descriptor-reg)) new-uwp)
126 (inst addi (* (tn-offset tn) n-word-bytes) cfp-tn new-uwp)
127 (store-symbol-value new-uwp *current-unwind-protect-block*)))
130 (define-vop (unlink-catch-block)
131 (:temporary (:scs (any-reg)) block)
133 (:translate %catch-breakup)
135 (load-symbol-value block *current-catch-block*)
136 (loadw block block catch-block-previous-catch-slot)
137 (store-symbol-value block *current-catch-block*)))
139 (define-vop (unlink-unwind-protect)
140 (:temporary (:scs (any-reg)) block)
142 (:translate %unwind-protect-breakup)
144 (load-symbol-value block *current-unwind-protect-block*)
145 (loadw block block unwind-block-current-uwp-slot)
146 (store-symbol-value block *current-unwind-protect-block*)))
152 (define-vop (nlx-entry)
153 (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
154 ; would be inserted before the LRA.
157 (:results (values :more t))
158 (:temporary (:scs (descriptor-reg)) move-temp)
160 (:save-p :force-to-stack)
163 (emit-return-pc label)
164 (note-this-location vop :non-local-entry)
165 (cond ((zerop nvals))
167 (inst comclr count zero-tn zero-tn :<>)
168 (inst move null-tn (tn-ref-tn values) :tr)
169 (loadw (tn-ref-tn values) start))
171 (collect ((defaults))
173 (tn-ref values (tn-ref-across tn-ref)))
175 (let ((default-lab (gen-label))
176 (tn (tn-ref-tn tn-ref)))
177 (defaults (cons default-lab tn))
179 (inst bci := nil (fixnumize i) count default-lab)
181 ((descriptor-reg any-reg)
184 (loadw move-temp start i)
185 (store-stack-tn tn move-temp)))))
187 (let ((defaulting-done (gen-label)))
188 (emit-label defaulting-done)
190 (assemble (*elsewhere*)
191 (do ((defs (defaults) (cdr defs)))
193 (let ((def (car defs)))
194 (emit-label (car def))
196 (inst b defaulting-done))
197 (let ((tn (cdr def)))
199 ((descriptor-reg any-reg)
202 (store-stack-tn tn null-tn)))))))))))
203 (load-stack-tn csp-tn sp)))
206 (define-vop (nlx-entry-multiple)
207 (:args (top :target dst) (start :target src) (count :target num))
208 ;; Again, no SC restrictions for the args, 'cause the loading would
209 ;; happen before the entry label.
211 (:temporary (:scs (any-reg) :from (:argument 0)) dst)
212 (:temporary (:scs (any-reg) :from (:argument 1)) src)
213 (:temporary (:scs (any-reg) :from (:argument 2)) num)
214 (:temporary (:scs (descriptor-reg)) temp)
215 (:results (new-start) (new-count))
216 (:save-p :force-to-stack)
219 (emit-return-pc label)
220 (note-this-location vop :non-local-entry)
223 (load-stack-tn dst top)
227 ;; Establish results.
229 (any-reg (move dst new-start))
230 (control-stack (store-stack-tn new-start dst)))
231 (inst comb := num zero-tn done)
233 (any-reg (inst move num new-count))
234 (control-stack (store-stack-tn new-count num)))
235 ;; Load the first word.
236 (inst ldwm n-word-bytes src temp)
238 ;; Copy stuff on stack.
240 (inst stwm temp n-word-bytes dst)
241 (inst addib :<> (fixnumize -1) num loop :nullify t)
242 (inst ldwm n-word-bytes src temp)
245 (inst move dst csp-tn)))
248 ;;; This VOP is just to force the TNs used in the cleanup onto the stack.
250 (define-vop (uwp-entry)
252 (:save-p :force-to-stack)
253 (:results (block) (start) (count))
254 (:ignore block start count)
257 (emit-return-pc label)
258 (note-this-location vop :non-local-entry)))