1(in-package "SB!VM")
2
3;;;; Return-multiple with other than one value
4
5#+sb-assembling ;; we don't want a vop for this one.
6(define-assembly-routine
7    (return-multiple
8     (:return-style :none))
9
10     ;; These four are really arguments.
11    ((:temp nvals any-reg nargs-offset)
12     (:temp vals any-reg ocfp-offset)
13     (:temp old-fp any-reg nl2-offset)
14     (:temp lra descriptor-reg lexenv-offset)
15
16     ;; These are just needed to facilitate the transfer
17     (:temp count any-reg nfp-offset)
18     (:temp src any-reg code-offset)
19     (:temp dst descriptor-reg r8-offset)
20
21     ;; These are needed so we can get at the register args.
22     (:temp r0 descriptor-reg r0-offset)
23     (:temp r1 descriptor-reg r1-offset)
24     (:temp r2 descriptor-reg r2-offset))
25
26  ;; Note, because of the way the return-multiple vop is written, we
27  ;; can assume that we are never called with nvals == 1 (not that it
28  ;; helps overmuch).
29
30  ;; If there are more return values than there are arg-passing
31  ;; registers, then we need to arrange for the excess values to be
32  ;; moved.
33  (inst cmp nvals (fixnumize 3))
34  (inst b :gt MOVE-STACK-VALUES)
35
36  ;; We don't need to copy stack values at this point, so default any
37  ;; unsupplied values that should be in arg-passing registers.  First
38  ;; piece of black magic: A computed jump.
39  (inst add pc-tn pc-tn nvals)
40  ;; Eat a word of padding for the computed jump.
41  (inst word 0)
42
43  ;; The computed jump above will land on one of the next four
44  ;; instructions, based on the number of values to return.
45  (inst mov r0 null-tn)
46  (inst mov r1 null-tn)
47  (inst mov r2 null-tn)
48
49  ;; We've defaulted any unsupplied parameters, but now we need to
50  ;; load the supplied parameters.  Second piece of black magic: A
51  ;; hairier computed jump.
52  (inst rsb count nvals (fixnumize 2))
53  (inst add pc-tn pc-tn count)
54
55  ;; The computed jump above will land on one of the next four
56  ;; instructions, based on the number of values to return, in reverse
57  ;; order.
58  (inst ldr r2 (@ vals (* 2 n-word-bytes)))
59
60  ;; If we need to copy stack values, we land here so as to load the
61  ;; first two register values (the third will be loaded after the
62  ;; values are copied, due to register pressure).
63  MOVE-STACK-VALUES
64  (inst ldr r1 (@ vals n-word-bytes))
65  (inst ldr r0 (@ vals))
66
67  ;; The last instruction to set the flags was the CMP to check to see
68  ;; if we needed to move the values on the stack.  If we do not need
69  ;; to move the values on the stack then we're almost done.
70  (inst b :le DONE)
71
72  ;; Copy the remaining args (including the future R2 register value)
73  ;; over the outbound stack frame.
74  (inst add src vals (* 2 n-word-bytes))
75  (inst add dst cfp-tn (* 2 n-word-bytes))
76  (inst sub count nvals (fixnumize 2))
77
78  LOOP
79  (inst subs count count (fixnumize 1))
80  (inst ldr r2 (@ src n-word-bytes :post-index))
81  (inst str r2 (@ dst n-word-bytes :post-index))
82  (inst b :ge LOOP)
83
84  ;; Load the last remaining register result.
85  (inst ldr r2 (@ cfp-tn (* 2 n-word-bytes)))
86
87  DONE
88
89  ;; Deallocate the unused stack space.
90  (move ocfp-tn cfp-tn)
91  (move cfp-tn old-fp)
92  (inst add dst ocfp-tn nvals)
93  (store-csp dst)
94
95  ;; Return.
96  (lisp-return lra :multiple-values))
97
98;;;; tail-call-variable.
99
100#+sb-assembling ;; no vop for this one either.
101(define-assembly-routine
102    (tail-call-variable
103     (:return-style :none))
104
105    ;; These are really args.
106    ((:temp args any-reg nl2-offset)
107     (:temp lexenv descriptor-reg lexenv-offset)
108
109     ;; We need to compute this
110     (:temp nargs any-reg nargs-offset)
111
112     ;; These are needed by the blitting code.
113     (:temp dest any-reg nl2-offset) ;; Not live concurrent with ARGS.
114     (:temp count any-reg nl3-offset)
115     (:temp temp descriptor-reg r8-offset)
116     (:temp stack-top non-descriptor-reg ocfp-offset)
117
118     ;; These are needed so we can get at the register args.
119     (:temp r0 descriptor-reg r0-offset)
120     (:temp r1 descriptor-reg r1-offset)
121     (:temp r2 descriptor-reg r2-offset))
122
123  ;; We're in a tail-call scenario, so we use the existing LRA and
124  ;; OCFP, both already set up in the stack frame.  We have a set of
125  ;; arguments, represented as the address of the first argument
126  ;; (ARGS) and the address just beyond the last argument (CSP-TN),
127  ;; and need to set up the arg-passing-registers (R0, R1, and R2),
128  ;; any stack arguments (the fourth and subsequent arguments, if such
129  ;; exist), and the total arg count (NARGS).
130
131  ;; Calculate NARGS (as a fixnum)
132  (load-csp nargs)
133  (inst sub nargs nargs args)
134
135  ;; Load the argument regs (must do this now, 'cause the blt might
136  ;; trash these locations, and we need ARGS to be dead for the blt)
137  (loadw r0 args 0)
138  (loadw r1 args 1)
139  (loadw r2 args 2)
140
141  ;; ARGS is now dead, we access the remaining arguments by offset
142  ;; from CSP-TN.
143
144  ;; Figure out how many arguments we really need to shift.
145  (inst subs count nargs (fixnumize register-arg-count))
146  ;; If there aren't any stack args then we're done.
147  (inst b :le DONE)
148
149  ;; Find where our shifted arguments ned to go.
150  (inst add dest cfp-tn nargs)
151
152  ;; And come from.
153  (load-csp stack-top)
154
155  LOOP
156  ;; Copy one arg.
157  (inst ldr temp (@ stack-top (- count)))
158  (inst str temp (@ dest (- count)))
159  (inst subs count count n-word-bytes)
160  (inst b :ne LOOP)
161
162  DONE
163  ;; The call frame is all set up, so all that remains is to jump to
164  ;; the new function.  We need a boxed register to hold the actual
165  ;; function object (in case of closure functions or funcallable
166  ;; instances), and R8 (known as TEMP) and, technically, CODE happen
167  ;; to be the only ones available.
168  (loadw temp lexenv closure-fun-slot fun-pointer-lowtag)
169  (lisp-jump temp))
170
171;;;; Non-local exit noise.
172
173(define-assembly-routine (throw
174                          (:return-style :none))
175                         ((:arg target descriptor-reg r0-offset)
176                          (:arg start any-reg r8-offset)
177                          (:arg count any-reg nargs-offset)
178                          (:temp catch any-reg r1-offset)
179                          (:temp tag descriptor-reg r2-offset))
180  (declare (ignore start count))
181
182  (load-symbol-value catch *current-catch-block*)
183
184  LOOP
185
186  (let ((error (generate-error-code nil 'unseen-throw-tag-error target)))
187    (inst cmp catch 0)
188    (inst b :eq error))
189
190  (loadw tag catch catch-block-tag-slot)
191  (inst cmp tag target)
192  (loadw catch catch catch-block-previous-catch-slot 0 :ne)
193  (inst b :ne LOOP)
194
195  ;; As a dreadful cleverness, make use of the fact that assembly
196  ;; routines are emitted in order, with no padding, and that the body
197  ;; of UNWIND follows to arrange for the stack to be unwound to our
198  ;; chosen destination.
199  (move target catch) ;; TARGET coincides with UNWIND's BLOCK argument
200  )
201
202(define-assembly-routine (unwind
203                          (:return-style :none)
204                          (:translate %continue-unwind)
205                          (:policy :fast-safe))
206                         ((:arg block (any-reg descriptor-reg) r0-offset)
207                          (:arg start (any-reg descriptor-reg) r8-offset)
208                          (:arg count (any-reg descriptor-reg) nargs-offset)
209                          (:temp ocfp non-descriptor-reg ocfp-offset)
210                          (:temp lra descriptor-reg lexenv-offset)
211                          (:temp cur-uwp any-reg nl2-offset))
212  (declare (ignore start count))
213
214  (let ((error (generate-error-code nil 'invalid-unwind-error)))
215    (inst cmp block 0)
216    (inst b :eq error))
217
218  (load-symbol-value cur-uwp *current-unwind-protect-block*)
219  (loadw ocfp block unwind-block-uwp-slot)
220  (inst cmp cur-uwp ocfp)
221
222  (loadw ocfp cur-uwp unwind-block-uwp-slot 0 :ne)
223  (store-symbol-value ocfp *current-unwind-protect-block* :ne)
224
225  (move cur-uwp block :eq)
226
227  (loadw cfp-tn cur-uwp unwind-block-cfp-slot)
228  (loadw code-tn cur-uwp unwind-block-code-slot)
229  (loadw lra cur-uwp unwind-block-entry-pc-slot)
230  (lisp-return lra :known))
231