0.8.17.17:
[sbcl.git] / src / compiler / alpha / nlx.lisp
1 ;;;; the definitions of VOPs used for non-local exit (THROW, lexical
2 ;;;; 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 (!def-vm-support-routine 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
22 ;;; non-local entry.
23 (!def-vm-support-routine make-nlx-entry-arg-start-location ()
24   (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset))
25 \f
26 ;;;; save and restoring the 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
32 ;;;; are implicitly processed during unwinding. If there were any
33 ;;;; additional stacks (as e.g. there was an interpreter "eval stack"
34 ;;;; before sbcl-0.7.0), then this would be the place to restore the
35 ;;;; top pointers.
36
37 (define-vop (save-dynamic-state)
38   (:results (catch :scs (descriptor-reg))
39             (nfp :scs (descriptor-reg))
40             (nsp :scs (descriptor-reg)))
41   (:vop-var vop)
42   (:generator 13
43     (load-symbol-value catch *current-catch-block*)
44     (let ((cur-nfp (current-nfp-tn vop)))
45       (when cur-nfp
46         (inst mskll cur-nfp 4 nfp)))
47     (inst mskll nsp-tn 4 nsp)))
48
49 (define-vop (restore-dynamic-state)
50   (:args (catch :scs (descriptor-reg))
51          (nfp :scs (descriptor-reg))
52          (nsp :scs (descriptor-reg)))
53   (:vop-var vop)
54   (:temporary (:sc any-reg) temp)
55   (:generator 10
56     (store-symbol-value catch *current-catch-block*)
57     (inst mskll nsp-tn 0 temp)
58     (let ((cur-nfp (current-nfp-tn vop)))
59       (when cur-nfp
60         (inst bis nfp temp cur-nfp)))
61     (inst bis nsp temp nsp-tn)))
62
63 (define-vop (current-stack-pointer)
64   (:results (res :scs (any-reg descriptor-reg)))
65   (:generator 1
66     (move csp-tn res)))
67
68 (define-vop (current-binding-pointer)
69   (:results (res :scs (any-reg descriptor-reg)))
70   (:generator 1
71     (move bsp-tn res)))
72 \f
73 ;;;; unwind block hackery
74
75 ;;; Compute the address of the catch block from its TN, then store
76 ;;; into the block the current Fp, Env, Unwind-Protect, and the entry PC.
77 (define-vop (make-unwind-block)
78   (:args (tn))
79   (:info entry-label)
80   (:results (block :scs (any-reg)))
81   (:temporary (:scs (descriptor-reg)) temp)
82   (:temporary (:scs (non-descriptor-reg)) ndescr)
83   (:generator 22
84     (inst lda block (* (tn-offset tn) n-word-bytes) cfp-tn)
85     (load-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)))
91
92
93 ;;; This is like Make-Unwind-Block, except that we also store in the
94 ;;; specified tag, and link the block into the Current-Catch list.
95 (define-vop (make-catch-block)
96   (:args (tn)
97          (tag :scs (any-reg descriptor-reg)))
98   (:info entry-label)
99   (:results (block :scs (any-reg)))
100   (:temporary (:scs (descriptor-reg)) temp)
101   (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result)
102   (:temporary (:scs (non-descriptor-reg)) ndescr)
103   (:generator 44
104     (inst lda result (* (tn-offset tn) n-word-bytes) cfp-tn)
105     (load-symbol-value temp *current-unwind-protect-block*)
106     (storew temp result catch-block-current-uwp-slot)
107     (storew cfp-tn result catch-block-current-cont-slot)
108     (storew code-tn result catch-block-current-code-slot)
109     (inst compute-lra-from-code temp code-tn entry-label ndescr)
110     (storew temp result catch-block-entry-pc-slot)
111
112     (storew tag result catch-block-tag-slot)
113     (load-symbol-value temp *current-catch-block*)
114     (storew temp result catch-block-previous-catch-slot)
115     (store-symbol-value result *current-catch-block*)
116
117     (move result block)))
118
119 ;;; Just set the current unwind-protect to TN's address. This
120 ;;; instantiates an 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 lda new-uwp (* (tn-offset tn) n-word-bytes) cfp-tn)
126     (store-symbol-value new-uwp *current-unwind-protect-block*)))
127
128 (define-vop (unlink-catch-block)
129   (:temporary (:scs (any-reg)) block)
130   (:policy :fast-safe)
131   (:translate %catch-breakup)
132   (:generator 17
133     (load-symbol-value block *current-catch-block*)
134     (loadw block block catch-block-previous-catch-slot)
135     (store-symbol-value block *current-catch-block*)))
136
137 (define-vop (unlink-unwind-protect)
138   (:temporary (:scs (any-reg)) block)
139   (:policy :fast-safe)
140   (:translate %unwind-protect-breakup)
141   (:generator 17
142     (load-symbol-value block *current-unwind-protect-block*)
143     (loadw block block unwind-block-current-uwp-slot)
144     (store-symbol-value block *current-unwind-protect-block*)))
145 \f
146 ;;;; NLX entry VOPs
147
148 (define-vop (nlx-entry)
149   (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
150               ; would be inserted before the LRA.
151          (start)
152          (count))
153   (:results (values :more t))
154   (:temporary (:scs (descriptor-reg)) move-temp)
155   (:temporary (:sc non-descriptor-reg) temp)
156   (:info label nvals)
157   (:save-p :force-to-stack)
158   (:vop-var vop)
159   (:generator 30
160     (emit-return-pc label)
161     (note-this-location vop :non-local-entry)
162     (cond ((zerop nvals))
163           ((= nvals 1)
164            (let ((no-values (gen-label)))
165              (move null-tn (tn-ref-tn values))
166              (inst beq count no-values)
167              (loadw (tn-ref-tn values) start)
168              (emit-label no-values)))
169           (t
170            (collect ((defaults))
171              (do ((i 0 (1+ i))
172                   (tn-ref values (tn-ref-across tn-ref)))
173                  ((null tn-ref))
174                (let ((default-lab (gen-label))
175                      (tn (tn-ref-tn tn-ref)))
176                  (defaults (cons default-lab tn))
177                  
178                  (inst move count temp)
179                  (inst lda count (fixnumize -1) count)
180                  (inst beq temp default-lab)
181                  (sc-case tn
182                           ((descriptor-reg any-reg)
183                            (loadw tn start i))
184                           (control-stack
185                            (loadw move-temp start i)
186                            (store-stack-tn tn move-temp)))))
187              
188              (let ((defaulting-done (gen-label)))
189                
190                (emit-label defaulting-done)
191                
192                (assemble (*elsewhere*)
193                  (dolist (def (defaults))
194                    (emit-label (car def))
195                    (let ((tn (cdr def)))
196                      (sc-case tn
197                               ((descriptor-reg any-reg)
198                                (move null-tn tn))
199                               (control-stack
200                                (store-stack-tn tn null-tn)))))
201                  (inst br zero-tn defaulting-done))))))
202     (load-stack-tn csp-tn sp)))
203
204 (define-vop (nlx-entry-multiple)
205   (:args (top :target dst) (start :target src) (count :target num))
206   ;; Again, no SC restrictions for the args, 'cause the loading would
207   ;; happen before the entry label.
208   (:info label)
209   (:temporary (:scs (any-reg) :from (:argument 0)) dst)
210   (:temporary (:scs (any-reg) :from (:argument 1)) src)
211   (:temporary (:scs (any-reg) :from (:argument 2)) num)
212   (:temporary (:scs (descriptor-reg)) temp)
213   (:results (new-start) (new-count))
214   (:save-p :force-to-stack)
215   (:vop-var vop)
216   (:generator 30
217     (emit-return-pc label)
218     (note-this-location vop :non-local-entry)
219     (let ((loop (gen-label))
220           (done (gen-label)))
221
222       ;; Copy args.
223       (load-stack-tn dst top)
224       (move start src)
225       (move count num)
226
227       ;; Establish results.
228       (sc-case new-start
229         (any-reg (move dst new-start))
230         (control-stack (store-stack-tn new-start dst)))
231       (sc-case new-count
232         (any-reg (inst move num new-count))
233         (control-stack (store-stack-tn new-count num)))
234       (inst beq num done)
235
236       ;; Copy stuff on stack.
237       (emit-label loop)
238       (loadw temp src)
239       (inst lda src n-word-bytes src)
240       (storew temp dst)
241       (inst lda num (fixnumize -1) num)
242       (inst lda dst n-word-bytes dst)
243       (inst bne num loop)
244
245       (emit-label done)
246       (inst move dst csp-tn))))
247
248 ;;; This VOP is just to force the TNs used in the cleanup onto the stack.
249 (define-vop (uwp-entry)
250   (:info label)
251   (:save-p :force-to-stack)
252   (:results (block) (start) (count))
253   (:ignore block start count)
254   (:vop-var vop)
255   (:generator 0
256     (emit-return-pc label)
257     (note-this-location vop :non-local-entry)))