1.0.9.13: copy the WRAPPER-SLOT-TABLE in FORCE-CACHE-FLUSHES
[sbcl.git] / src / assembly / hppa / assem-rtns.lisp
1 (in-package "SB!VM")
2
3 \f
4 ;;;; Return-multiple with other than one value
5
6 #+sb-assembling ;; we don't want a vop for this one.
7 (define-assembly-routine
8     (return-multiple
9      (:return-style :none))
10
11      ;; These four are really arguments.
12     ((:temp nvals any-reg nargs-offset)
13      (:temp vals any-reg nl0-offset)
14      (:temp old-fp any-reg nl1-offset)
15      (:temp lra descriptor-reg lra-offset)
16
17      ;; These are just needed to facilitate the transfer
18      (:temp count any-reg nl2-offset)
19      (:temp src any-reg nl3-offset)
20      (:temp dst any-reg nl4-offset)
21      (:temp temp descriptor-reg l0-offset)
22
23      ;; These are needed so we can get at the register args.
24      (:temp a0 descriptor-reg a0-offset)
25      (:temp a1 descriptor-reg a1-offset)
26      (:temp a2 descriptor-reg a2-offset)
27      (:temp a3 descriptor-reg a3-offset)
28      (:temp a4 descriptor-reg a4-offset)
29      (:temp a5 descriptor-reg a5-offset))
30
31   (inst movb := nvals count default-a0-and-on :nullify t)
32   (loadw a0 vals 0)
33   (inst addib := (fixnumize -1) count default-a1-and-on :nullify t)
34   (loadw a1 vals 1)
35   (inst addib := (fixnumize -1) count default-a2-and-on :nullify t)
36   (loadw a2 vals 2)
37   (inst addib := (fixnumize -1) count default-a3-and-on :nullify t)
38   (loadw a3 vals 3)
39   (inst addib := (fixnumize -1) count default-a4-and-on :nullify t)
40   (loadw a4 vals 4)
41   (inst addib := (fixnumize -1) count default-a5-and-on :nullify t)
42   (loadw a5 vals 5)
43   (inst addib := (fixnumize -1) count done :nullify t)
44
45   ;; Copy the remaining args to the top of the stack.
46   (inst addi (* 6 n-word-bytes) vals src)
47   (inst addi (* 6 n-word-bytes) cfp-tn dst)
48
49   LOOP
50   (inst ldwm 4 src temp)
51   (inst addib :> (fixnumize -1) count loop)
52   (inst stwm temp 4 dst)
53
54   (inst b done :nullify t)
55
56   DEFAULT-A0-AND-ON
57   (inst move null-tn a0)
58   DEFAULT-A1-AND-ON
59   (inst move null-tn a1)
60   DEFAULT-A2-AND-ON
61   (inst move null-tn a2)
62   DEFAULT-A3-AND-ON
63   (inst move null-tn a3)
64   DEFAULT-A4-AND-ON
65   (inst move null-tn a4)
66   DEFAULT-A5-AND-ON
67   (inst move null-tn a5)
68
69   DONE
70   ;; Clear the stack.
71   (move cfp-tn ocfp-tn)
72   (move old-fp cfp-tn)
73   (inst add ocfp-tn nvals csp-tn)
74
75   ;; Return.
76   (lisp-return lra))
77
78
79 \f
80 ;;;; tail-call-variable.
81
82 #+sb-assembling ;; no vop for this one either.
83 (define-assembly-routine
84     (tail-call-variable
85      (:return-style :none))
86
87     ;; These are really args.
88     ((:temp args any-reg nl0-offset)
89      (:temp lexenv descriptor-reg lexenv-offset)
90
91      ;; We need to compute this
92      (:temp nargs any-reg nargs-offset)
93
94      ;; These are needed by the blitting code.
95      (:temp src any-reg nl1-offset)
96      (:temp dst any-reg nl2-offset)
97      (:temp count any-reg nl3-offset)
98      (:temp temp descriptor-reg l0-offset)
99
100      ;; These are needed so we can get at the register args.
101      (:temp a0 descriptor-reg a0-offset)
102      (:temp a1 descriptor-reg a1-offset)
103      (:temp a2 descriptor-reg a2-offset)
104      (:temp a3 descriptor-reg a3-offset)
105      (:temp a4 descriptor-reg a4-offset)
106      (:temp a5 descriptor-reg a5-offset))
107
108
109   ;; Calculate NARGS (as a fixnum)
110   (inst sub csp-tn args nargs)
111
112   ;; Load the argument regs (must do this now, 'cause the blt might
113   ;; trash these locations)
114   (loadw a0 args 0)
115   (loadw a1 args 1)
116   (loadw a2 args 2)
117   (loadw a3 args 3)
118   (loadw a4 args 4)
119   (loadw a5 args 5)
120
121   ;; Calc SRC, DST, and COUNT
122   (inst addi (fixnumize (- register-arg-count)) nargs count)
123   (inst comb :<= count zero-tn done :nullify t)
124   (inst addi (* n-word-bytes register-arg-count) args src)
125   (inst addi (* n-word-bytes register-arg-count) cfp-tn dst)
126
127   LOOP
128   ;; Copy one arg.
129   (inst ldwm 4 src temp)
130   (inst addib :> (fixnumize -1) count loop)
131   (inst stwm temp 4 dst)
132
133   DONE
134   ;; We are done.  Do the jump.
135   (loadw temp lexenv closure-fun-slot fun-pointer-lowtag)
136   (lisp-jump temp))
137
138
139 \f
140 ;;;; Non-local exit noise.
141
142 ;;; FIXME: Really?
143 #+sb-assembling
144 (defparameter *unwind-entry-point* (gen-label))
145
146 (define-assembly-routine
147     (unwind
148      (:translate %continue-unwind)
149      (:policy :fast-safe))
150     ((:arg block (any-reg descriptor-reg) a0-offset)
151      (:arg start (any-reg descriptor-reg) ocfp-offset)
152      (:arg count (any-reg descriptor-reg) nargs-offset)
153      (:temp lra descriptor-reg lra-offset)
154      (:temp cur-uwp any-reg nl0-offset)
155      (:temp next-uwp any-reg nl1-offset)
156      (:temp target-uwp any-reg nl2-offset))
157   (declare (ignore start count))
158
159   (emit-label *unwind-entry-point*)
160
161   (let ((error (generate-error-code nil invalid-unwind-error)))
162     (inst bc := nil block zero-tn error))
163
164   (load-symbol-value cur-uwp *current-unwind-protect-block*)
165   (loadw target-uwp block unwind-block-current-uwp-slot)
166   (inst bc :<> nil cur-uwp target-uwp do-uwp)
167
168   (move block cur-uwp)
169
170   DO-EXIT
171
172   (loadw cfp-tn cur-uwp unwind-block-current-cont-slot)
173   (loadw code-tn cur-uwp unwind-block-current-code-slot)
174   (loadw lra cur-uwp unwind-block-entry-pc-slot)
175   (lisp-return lra :frob-code nil)
176
177   DO-UWP
178
179   (loadw next-uwp cur-uwp unwind-block-current-uwp-slot)
180   (inst b do-exit)
181   (store-symbol-value next-uwp *current-unwind-protect-block*))
182
183
184 (define-assembly-routine
185     throw
186     ((:arg target descriptor-reg a0-offset)
187      (:arg start any-reg ocfp-offset)
188      (:arg count any-reg nargs-offset)
189      (:temp catch any-reg a1-offset)
190      (:temp tag descriptor-reg a2-offset))
191   (declare (ignore start count)) ; We just need them in the registers.
192
193   (load-symbol-value catch *current-catch-block*)
194
195   LOOP
196   (let ((error (generate-error-code nil unseen-throw-tag-error target)))
197     (inst bc := nil catch zero-tn error))
198   (loadw tag catch catch-block-tag-slot)
199   (inst comb :<> tag target loop :nullify t)
200   (loadw catch catch catch-block-previous-catch-slot)
201
202   (inst b *unwind-entry-point*)
203   (inst move catch target))