1.0.19.16: derive the type of (AREF (THE STRING X) Y) as CHARACTER
[sbcl.git] / src / compiler / hppa / nlx.lisp
1 (in-package "SB!VM")
2
3 ;;; Make an environment-live stack TN for saving the SP for NLX entry.
4 (!def-vm-support-routine make-nlx-sp-tn (env)
5   (physenv-live-tn
6    (make-representation-tn *fixnum-primitive-type* immediate-arg-scn)
7    env))
8
9 ;;; Make a TN for the argument count passing location for a
10 ;;; non-local entry.
11 (!def-vm-support-routine make-nlx-entry-arg-start-location ()
12   (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset))
13
14 \f
15 ;;; Save and restore dynamic environment.
16 ;;;
17 ;;;    These VOPs are used in the reentered function to restore the appropriate
18 ;;; dynamic environment.  Currently we only save the Current-Catch and binding
19 ;;; stack pointer.  We don't need to save/restore the current unwind-protect,
20 ;;; since unwind-protects are implicitly processed during unwinding.  If there
21 ;;; were any additional stacks, then this would be the place to restore the top
22 ;;; pointers.
23
24 (define-vop (save-dynamic-state)
25   (:results (catch :scs (descriptor-reg))
26             (nfp :scs (descriptor-reg))
27             (nsp :scs (descriptor-reg)))
28   (:vop-var vop)
29   (:generator 13
30     (load-symbol-value catch *current-catch-block*)
31     (let ((cur-nfp (current-nfp-tn vop)))
32       (when cur-nfp
33         (move cur-nfp nfp)))
34     (move nsp-tn nsp)))
35
36 (define-vop (restore-dynamic-state)
37   (:args (catch :scs (descriptor-reg))
38          (nfp :scs (descriptor-reg))
39          (nsp :scs (descriptor-reg)))
40   (:vop-var vop)
41   (:generator 10
42     (store-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 (current-stack-pointer)
49   (:results (res :scs (any-reg descriptor-reg)))
50   (:generator 1
51     (move csp-tn res)))
52
53 (define-vop (current-binding-pointer)
54   (:results (res :scs (any-reg descriptor-reg)))
55   (:generator 1
56     (move bsp-tn res)))
57
58 \f
59 ;;;; Unwind block hackery:
60
61 ;;; Compute the address of the catch block from its TN, then store into the
62 ;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
63 ;;;
64 (define-vop (make-unwind-block)
65   (:args (tn))
66   (:info entry-label)
67   (:results (block :scs (any-reg)))
68   (:temporary (:scs (descriptor-reg)) temp)
69   (:temporary (:scs (non-descriptor-reg)) ndescr)
70   (:generator 22
71     (inst addi (* (tn-offset tn) n-word-bytes) cfp-tn block)
72     (load-symbol-value temp *current-unwind-protect-block*)
73     (storew temp block unwind-block-current-uwp-slot)
74     (storew cfp-tn block unwind-block-current-cont-slot)
75     (storew code-tn block unwind-block-current-code-slot)
76     (inst compute-lra-from-code code-tn entry-label ndescr temp)
77     (storew temp block catch-block-entry-pc-slot)))
78
79 ;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
80 ;;; link the block into the Current-Catch list.
81 ;;;
82 (define-vop (make-catch-block)
83   (:args (tn)
84          (tag :scs (any-reg descriptor-reg)))
85   (:info entry-label)
86   (:results (block :scs (any-reg) :from (:argument 0)))
87   (:temporary (:scs (descriptor-reg)) temp)
88   (:temporary (:scs (non-descriptor-reg)) ndescr)
89   (:generator 44
90     (inst addi (* (tn-offset tn) n-word-bytes) cfp-tn block)
91     (load-symbol-value temp *current-unwind-protect-block*)
92     (storew temp block catch-block-current-uwp-slot)
93     (storew cfp-tn block catch-block-current-cont-slot)
94     (storew code-tn block catch-block-current-code-slot)
95     (inst compute-lra-from-code code-tn entry-label ndescr temp)
96     (storew temp block catch-block-entry-pc-slot)
97
98     (storew tag block catch-block-tag-slot)
99     (load-symbol-value temp *current-catch-block*)
100     (storew temp block catch-block-previous-catch-slot)
101     (store-symbol-value block *current-catch-block*)))
102
103
104 ;;; Just set the current unwind-protect to TN's address.  This instantiates an
105 ;;; unwind block as an unwind-protect.
106 ;;;
107 (define-vop (set-unwind-protect)
108   (:args (tn))
109   (:temporary (:scs (descriptor-reg)) new-uwp)
110   (:generator 7
111     (inst addi (* (tn-offset tn) n-word-bytes) cfp-tn new-uwp)
112     (store-symbol-value new-uwp *current-unwind-protect-block*)))
113
114
115 (define-vop (unlink-catch-block)
116   (:temporary (:scs (any-reg)) block)
117   (:policy :fast-safe)
118   (:translate %catch-breakup)
119   (:generator 17
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*)))
123
124 (define-vop (unlink-unwind-protect)
125   (:temporary (:scs (any-reg)) block)
126   (:policy :fast-safe)
127   (:translate %unwind-protect-breakup)
128   (:generator 17
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*)))
132
133 \f
134 ;;;; NLX entry VOPs:
135
136
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.
140          (start)
141          (count))
142   (:results (values :more t))
143   (:temporary (:scs (descriptor-reg)) move-temp)
144   (:info label nvals)
145   (:save-p :force-to-stack)
146   (:vop-var vop)
147   (:generator 30
148     (emit-return-pc label)
149     (note-this-location vop :non-local-entry)
150     (cond ((zerop nvals))
151           ((= nvals 1)
152            (inst comclr count zero-tn zero-tn :<>)
153            (inst move null-tn (tn-ref-tn values) :tr)
154            (loadw (tn-ref-tn values) start))
155           (t
156            (collect ((defaults))
157              (do ((i 0 (1+ i))
158                   (tn-ref values (tn-ref-across tn-ref)))
159                  ((null tn-ref))
160                (let ((default-lab (gen-label))
161                      (tn (tn-ref-tn tn-ref)))
162                  (defaults (cons default-lab tn))
163
164                  (inst bci := nil (fixnumize i) count default-lab)
165                  (sc-case tn
166                    ((descriptor-reg any-reg)
167                     (loadw tn start i))
168                    (control-stack
169                     (loadw move-temp start i)
170                     (store-stack-tn tn move-temp)))))
171
172              (let ((defaulting-done (gen-label)))
173                (emit-label defaulting-done)
174
175                (assemble (*elsewhere*)
176                  (do ((defs (defaults) (cdr defs)))
177                      ((null defs))
178                    (let ((def (car defs)))
179                      (emit-label (car def))
180                      (unless (cdr defs)
181                        (inst b defaulting-done))
182                      (let ((tn (cdr def)))
183                        (sc-case tn
184                          ((descriptor-reg any-reg)
185                           (move null-tn tn))
186                          (control-stack
187                           (store-stack-tn tn null-tn)))))))))))
188     (load-stack-tn csp-tn sp)))
189
190
191 (define-vop (nlx-entry-multiple)
192   (:args (top :target dst) (start :target src) (count :target num))
193   ;; Again, no SC restrictions for the args, 'cause the loading would
194   ;; happen before the entry label.
195   (:info label)
196   (:temporary (:scs (any-reg) :from (:argument 0)) dst)
197   (:temporary (:scs (any-reg) :from (:argument 1)) src)
198   (:temporary (:scs (any-reg) :from (:argument 2)) num)
199   (:temporary (:scs (descriptor-reg)) temp)
200   (:results (new-start) (new-count))
201   (:save-p :force-to-stack)
202   (:vop-var vop)
203   (:generator 30
204     (emit-return-pc label)
205     (note-this-location vop :non-local-entry)
206
207     ;; Copy args.
208     (load-stack-tn dst top)
209     (move start src)
210     (move count num)
211
212     ;; Establish results.
213     (sc-case new-start
214       (any-reg (move dst new-start))
215       (control-stack (store-stack-tn new-start dst)))
216     (inst comb := num zero-tn done)
217     (sc-case new-count
218       (any-reg (inst move num new-count))
219       (control-stack (store-stack-tn new-count num)))
220     ;; Load the first word.
221     (inst ldwm n-word-bytes src temp)
222
223     ;; Copy stuff on stack.
224     LOOP
225     (inst stwm temp n-word-bytes dst)
226     (inst addib :<> (fixnumize -1) num loop :nullify t)
227     (inst ldwm n-word-bytes src temp)
228
229     DONE
230     (inst move dst csp-tn)))
231
232
233 ;;; This VOP is just to force the TNs used in the cleanup onto the stack.
234 ;;;
235 (define-vop (uwp-entry)
236   (:info label)
237   (:save-p :force-to-stack)
238   (:results (block) (start) (count))
239   (:ignore block start count)
240   (:vop-var vop)
241   (:generator 0
242     (emit-return-pc label)
243     (note-this-location vop :non-local-entry)))