Closes https://bugs.launchpad.net/sbcl/+bug/911027
[sbcl.git] / src / assembly / ppc / 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 ocfp any-reg nl1-offset)
15      (:temp lra descriptor-reg lra-offset)
16
17      ;; These are just needed to facilitate the transfer
18      (:temp lip interior-reg lip-offset)
19      (:temp count any-reg nl2-offset)
20      (:temp src any-reg nl3-offset)
21      (:temp dst any-reg cfunc-offset)
22      (:temp temp descriptor-reg l0-offset)
23
24
25      ;; These are needed so we can get at the register args.
26      (:temp a0 descriptor-reg a0-offset)
27      (:temp a1 descriptor-reg a1-offset)
28      (:temp a2 descriptor-reg a2-offset)
29      (:temp a3 descriptor-reg a3-offset))
30
31   ;; Note, because of the way the return-multiple vop is written, we can
32   ;; assume that we are never called with nvals == 1 and that a0 has already
33   ;; been loaded.
34   (inst cmpwi nvals 0)
35   (inst ble default-a0-and-on)
36   (inst cmpwi nvals (fixnumize 2))
37   (inst lwz a1 vals (* 1 n-word-bytes))
38   (inst ble default-a2-and-on)
39   (inst cmpwi nvals (fixnumize 3))
40   (inst lwz a2 vals (* 2 n-word-bytes))
41   (inst ble default-a3-and-on)
42   (inst cmpwi nvals (fixnumize 4))
43   (inst lwz a3 vals (* 3 n-word-bytes))
44   (inst ble done)
45
46   ;; Copy the remaining args to the top of the stack.
47   (inst addi src vals (* 4 n-word-bytes))
48   (inst addi dst cfp-tn (* 4 n-word-bytes))
49   (inst addic. count nvals (- (fixnumize 4)))
50
51   LOOP
52   (inst subic. count count (fixnumize 1))
53   (inst lwz temp src 0)
54   (inst addi src src n-word-bytes)
55   (inst stw temp dst 0)
56   (inst addi dst dst n-word-bytes)
57   (inst bge loop)
58
59   (inst b done)
60
61   DEFAULT-A0-AND-ON
62   (inst mr a0 null-tn)
63   (inst mr a1 null-tn)
64   DEFAULT-A2-AND-ON
65   (inst mr a2 null-tn)
66   DEFAULT-A3-AND-ON
67   (inst mr a3 null-tn)
68   DONE
69
70   ;; Clear the stack.
71   (move ocfp-tn cfp-tn)
72   (move cfp-tn ocfp)
73   (inst add csp-tn ocfp-tn nvals)
74
75   ;; Return.
76   (lisp-return lra lip))
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      (:temp lip interior-reg lip-offset)
100
101      ;; These are needed so we can get at the register args.
102      (:temp a0 descriptor-reg a0-offset)
103      (:temp a1 descriptor-reg a1-offset)
104      (:temp a2 descriptor-reg a2-offset)
105      (:temp a3 descriptor-reg a3-offset))
106
107
108   ;; Calculate NARGS (as a fixnum)
109   (inst sub nargs csp-tn args)
110
111   ;; Load the argument regs (must do this now, 'cause the blt might
112   ;; trash these locations)
113   (inst lwz a0 args (* 0 n-word-bytes))
114   (inst lwz a1 args (* 1 n-word-bytes))
115   (inst lwz a2 args (* 2 n-word-bytes))
116   (inst lwz a3 args (* 3 n-word-bytes))
117
118   ;; Calc SRC, DST, and COUNT
119   (inst addic. count nargs (fixnumize (- register-arg-count)))
120   (inst addi src args (* n-word-bytes register-arg-count))
121   (inst ble done)
122   (inst addi dst cfp-tn (* n-word-bytes register-arg-count))
123
124   LOOP
125   ;; Copy one arg.
126   (inst lwz temp src 0)
127   (inst addi src src n-word-bytes)
128   (inst stw temp dst 0)
129   (inst addic. count count (fixnumize -1))
130   (inst addi dst dst n-word-bytes)
131   (inst bgt loop)
132
133   DONE
134   ;; We are done.  Do the jump.
135   (loadw temp lexenv closure-fun-slot fun-pointer-lowtag)
136   (lisp-jump temp lip))
137
138
139 \f
140 ;;;; Non-local exit noise.
141
142 (define-assembly-routine (unwind
143                           (:return-style :none)
144                           (:translate %continue-unwind)
145                           (:policy :fast-safe))
146                          ((:arg block (any-reg descriptor-reg) a0-offset)
147                           (:arg start (any-reg descriptor-reg) ocfp-offset)
148                           (:arg count (any-reg descriptor-reg) nargs-offset)
149                           (:temp lra descriptor-reg lra-offset)
150                           (:temp lip interior-reg lip-offset)
151                           (:temp cur-uwp any-reg nl0-offset)
152                           (:temp next-uwp any-reg nl1-offset)
153                           (:temp target-uwp any-reg nl2-offset))
154   (declare (ignore start count))
155
156   (let ((error (generate-error-code nil 'invalid-unwind-error)))
157     (inst cmpwi block 0)
158     (inst beq error))
159
160   (load-tl-symbol-value cur-uwp *current-unwind-protect-block*)
161   (loadw target-uwp block unwind-block-current-uwp-slot)
162   (inst cmpw cur-uwp target-uwp)
163   (inst bne do-uwp)
164
165   (move cur-uwp block)
166
167   DO-EXIT
168
169   (loadw cfp-tn cur-uwp unwind-block-current-cont-slot)
170   (loadw code-tn cur-uwp unwind-block-current-code-slot)
171   (loadw lra cur-uwp unwind-block-entry-pc-slot)
172   (lisp-return lra lip)
173
174   DO-UWP
175
176   (loadw next-uwp cur-uwp unwind-block-current-uwp-slot)
177   (store-tl-symbol-value next-uwp *current-unwind-protect-block* cfp-tn)
178   (inst b do-exit))
179
180 (define-assembly-routine (throw
181                           (:return-style :none))
182                          ((:arg target descriptor-reg a0-offset)
183                           (:arg start any-reg ocfp-offset)
184                           (:arg count any-reg nargs-offset)
185                           (:temp catch any-reg a1-offset)
186                           (:temp tag descriptor-reg a2-offset))
187
188   (declare (ignore start count))
189
190   (load-tl-symbol-value catch *current-catch-block*)
191
192   loop
193
194   (let ((error (generate-error-code nil 'unseen-throw-tag-error target)))
195     (inst cmpwi catch 0)
196     (inst beq error))
197
198   (loadw tag catch catch-block-tag-slot)
199   (inst cmpw tag target)
200   (inst beq exit)
201   (loadw catch catch catch-block-previous-catch-slot)
202   (inst b loop)
203
204   exit
205
206   (move target catch)
207   ;; reuse catch
208   (inst lr catch (make-fixup 'unwind :assembly-routine))
209   (inst mtlr catch)
210   (inst blr))