Pack (mostly) stack TNs according to lexical scope information
[sbcl.git] / src / compiler / sparc / nlx.lisp
1 ;;;; the SPARC definitions of VOPs used for non-local exit (throw,
2 ;;;; lexical exit, etc.)
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
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.
12
13 (in-package "SB!VM")
14
15 ;;; Make an environment-live stack TN for saving the SP for NLX entry.
16 (defun make-nlx-sp-tn (env)
17   (physenv-live-tn
18    (make-representation-tn *fixnum-primitive-type* immediate-arg-scn)
19    env))
20
21 ;;; Make a TN for the argument count passing location for a non-local
22 ;;; entry.
23 (defun make-nlx-entry-arg-start-location ()
24   (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset))
25 \f
26 ;;; save and restore dynamic environment.
27 ;;;
28 ;;; These VOPs are used in the reentered function to restore the
29 ;;; appropriate dynamic environment.  Currently we only save the
30 ;;; CURRENT-CATCH and binding stack pointer.  We don't need to
31 ;;; save/restore the current UNWIND-PROTECT, since UNWIND-PROTECTs are
32 ;;; implicitly processed during unwinding.  If there were any
33 ;;; additional stacks, then this would be the place to restore the top
34 ;;; pointers.
35
36 (define-vop (save-dynamic-state)
37     (:results (catch :scs (descriptor-reg))
38               (nfp :scs (descriptor-reg))
39               (nsp :scs (descriptor-reg)))
40   (:vop-var vop)
41   (:generator 13
42               (load-symbol-value catch *current-catch-block*)
43               (let ((cur-nfp (current-nfp-tn vop)))
44                 (when cur-nfp
45                   (move nfp cur-nfp)))
46               (move nsp nsp-tn)))
47
48 (define-vop (restore-dynamic-state)
49     (:args (catch :scs (descriptor-reg))
50            (nfp :scs (descriptor-reg))
51            (nsp :scs (descriptor-reg)))
52   (:vop-var vop)
53   (:generator 10
54               (store-symbol-value catch *current-catch-block*)
55               (let ((cur-nfp (current-nfp-tn vop)))
56                 (when cur-nfp
57                   (move cur-nfp nfp)))
58               (move nsp-tn nsp)))
59
60 (define-vop (current-stack-pointer)
61     (:results (res :scs (any-reg descriptor-reg)))
62   (:generator 1
63               (move res csp-tn)))
64
65 (define-vop (current-binding-pointer)
66     (:results (res :scs (any-reg descriptor-reg)))
67   (:generator 1
68               (move res bsp-tn)))
69
70 \f
71 ;;;; unwind block hackery:
72
73 ;;; Compute the address of the catch block from its TN, then store
74 ;;; into the block the current Fp, Env, Unwind-Protect, and the entry
75 ;;; PC.
76 (define-vop (make-unwind-block)
77   (:args (tn))
78   (:info entry-label)
79   (:results (block :scs (any-reg)))
80   (:temporary (:scs (descriptor-reg)) temp)
81   (:temporary (:scs (non-descriptor-reg)) ndescr)
82   (:generator 22
83     (inst add block cfp-tn (* (tn-offset tn) n-word-bytes))
84     (load-symbol-value temp *current-unwind-protect-block*)
85     (storew temp block unwind-block-current-uwp-slot)
86     (storew cfp-tn block unwind-block-current-cont-slot)
87     (storew code-tn block unwind-block-current-code-slot)
88     (inst compute-lra-from-code temp code-tn entry-label ndescr)
89     (storew temp block catch-block-entry-pc-slot)))
90
91
92 ;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
93 ;;; link the block into the Current-Catch list.
94 (define-vop (make-catch-block)
95   (:args (tn)
96          (tag :scs (any-reg descriptor-reg)))
97   (:info entry-label)
98   (:results (block :scs (any-reg)))
99   (:temporary (:scs (descriptor-reg)) temp)
100   (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result)
101   (:temporary (:scs (non-descriptor-reg)) ndescr)
102   (:generator 44
103     (inst add result cfp-tn (* (tn-offset tn) n-word-bytes))
104     (load-symbol-value temp *current-unwind-protect-block*)
105     (storew temp result catch-block-current-uwp-slot)
106     (storew cfp-tn result catch-block-current-cont-slot)
107     (storew code-tn result catch-block-current-code-slot)
108     (inst compute-lra-from-code temp code-tn entry-label ndescr)
109     (storew temp result catch-block-entry-pc-slot)
110
111     (storew tag result catch-block-tag-slot)
112     (load-symbol-value temp *current-catch-block*)
113     (storew temp result catch-block-previous-catch-slot)
114     (store-symbol-value result *current-catch-block*)
115
116     (move block result)))
117
118
119 ;;; Just set the current unwind-protect to TN's address.  This instantiates an
120 ;;; unwind block as an unwind-protect.
121 (define-vop (set-unwind-protect)
122   (:args (tn))
123   (:temporary (:scs (descriptor-reg)) new-uwp)
124   (:generator 7
125     (inst add new-uwp cfp-tn (* (tn-offset tn) n-word-bytes))
126     (store-symbol-value new-uwp *current-unwind-protect-block*)))
127
128
129 (define-vop (unlink-catch-block)
130   (:temporary (:scs (any-reg)) block)
131   (:policy :fast-safe)
132   (:translate %catch-breakup)
133   (:generator 17
134     (load-symbol-value block *current-catch-block*)
135     (loadw block block catch-block-previous-catch-slot)
136     (store-symbol-value block *current-catch-block*)))
137
138 (define-vop (unlink-unwind-protect)
139   (:temporary (:scs (any-reg)) block)
140   (:policy :fast-safe)
141   (:translate %unwind-protect-breakup)
142   (:generator 17
143     (load-symbol-value block *current-unwind-protect-block*)
144     (loadw block block unwind-block-current-uwp-slot)
145     (store-symbol-value block *current-unwind-protect-block*)))
146
147 \f
148 ;;;; NLX entry VOPs:
149
150
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.
154          (start)
155          (count))
156   (:results (values :more t))
157   (:temporary (:scs (descriptor-reg)) move-temp)
158   (:info label nvals)
159   (:save-p :force-to-stack)
160   (:vop-var vop)
161   (:generator 30
162     (emit-return-pc label)
163     (note-this-location vop :non-local-entry)
164     (cond ((zerop nvals))
165           ((= nvals 1)
166            (let ((no-values (gen-label)))
167              (inst cmp count)
168              (inst b :eq no-values)
169              (move (tn-ref-tn values) null-tn)
170              (loadw (tn-ref-tn values) start)
171              (emit-label no-values)))
172           (t
173            (collect ((defaults))
174              (inst subcc count (fixnumize 1))
175              (do ((i 0 (1+ i))
176                   (tn-ref values (tn-ref-across tn-ref)))
177                  ((null tn-ref))
178                (let ((default-lab (gen-label))
179                      (tn (tn-ref-tn tn-ref)))
180                  (defaults (cons default-lab tn))
181
182                  (inst b :lt default-lab)
183                  (inst subcc count (fixnumize 1))
184                  (sc-case tn
185                           ((descriptor-reg any-reg)
186                            (loadw tn start i))
187                           (control-stack
188                            (loadw move-temp start i)
189                            (store-stack-tn tn move-temp)))))
190
191              (let ((defaulting-done (gen-label)))
192
193                (emit-label defaulting-done)
194
195                (assemble (*elsewhere*)
196                  (dolist (def (defaults))
197                    (emit-label (car def))
198                    (let ((tn (cdr def)))
199                      (sc-case tn
200                               ((descriptor-reg any-reg)
201                                (move tn null-tn))
202                               (control-stack
203                                (store-stack-tn tn null-tn)))))
204                  (inst b defaulting-done)
205                  (inst nop))))))
206     (load-stack-tn csp-tn sp)))
207
208
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.
213   (:info 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)
219   (:vop-var vop)
220   (:generator 30
221     (emit-return-pc label)
222     (note-this-location vop :non-local-entry)
223     (let ((loop (gen-label))
224           (done (gen-label)))
225
226       ;; Setup results, and test for the zero value case.
227       (load-stack-tn result top)
228       (inst cmp count)
229       (inst b :eq done)
230       (inst li num 0)
231
232       ;; Compute dst as one slot down from result, because we inc the index
233       ;; before we use it.
234       (inst sub dst result 4)
235
236       ;; Copy stuff down the stack.
237       (emit-label loop)
238       (inst ld temp src num)
239       (inst add num (fixnumize 1))
240       (inst cmp num count)
241       (inst b :ne loop)
242       (inst st temp dst num)
243
244       ;; Reset the CSP.
245       (emit-label done)
246       (inst add csp-tn result num))))
247
248
249 ;;; This VOP is just to force the TNs used in the cleanup onto the stack.
250 ;;;
251 (define-vop (uwp-entry)
252   (:info label)
253   (:save-p :force-to-stack)
254   (:results (block) (start) (count))
255   (:ignore block start count)
256   (:vop-var vop)
257   (:generator 0
258     (emit-return-pc label)
259     (note-this-location vop :non-local-entry)))
260