1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
12 ;;;; Return-multiple with other than one value
14 #+sb-assembling
;; We don't want a vop for this one.
15 (define-assembly-routine
17 (:return-style
:none
))
19 ;; These four are really arguments.
20 ((:temp nvals any-reg nargs-offset
)
21 (:temp vals any-reg nl0-offset
)
22 (:temp ocfp any-reg nl1-offset
)
23 (:temp lra descriptor-reg lra-offset
)
25 ;; These are just needed to facilitate the transfer
26 (:temp lip interior-reg lip-offset
)
27 (:temp count any-reg nl2-offset
)
28 (:temp dst any-reg nl4-offset
)
29 (:temp temp descriptor-reg l0-offset
)
31 ;; These are needed so we can get at the register args.
32 (:temp a0 descriptor-reg a0-offset
)
33 (:temp a1 descriptor-reg a1-offset
)
34 (:temp a2 descriptor-reg a2-offset
)
35 (:temp a3 descriptor-reg a3-offset
)
36 (:temp a4 descriptor-reg a4-offset
)
37 (:temp a5 descriptor-reg a5-offset
))
39 ;; Note, because of the way the RETURN-MULTIPLE VOP is written, we
40 ;; can assume that we are never called with NVALS == 1 and that A0
41 ;; has already been loaded.
42 (inst ble nvals default-a0-and-on
)
43 (inst ldl a1
(* 1 n-word-bytes
) vals
)
44 (inst subq nvals
(fixnumize 2) count
)
45 (inst ble count default-a2-and-on
)
46 (inst ldl a2
(* 2 n-word-bytes
) vals
)
47 (inst subq nvals
(fixnumize 3) count
)
48 (inst ble count default-a3-and-on
)
49 (inst ldl a3
(* 3 n-word-bytes
) vals
)
50 (inst subq nvals
(fixnumize 4) count
)
51 (inst ble count default-a4-and-on
)
52 (inst ldl a4
(* 4 n-word-bytes
) vals
)
53 (inst subq nvals
(fixnumize 5) count
)
54 (inst ble count default-a5-and-on
)
55 (inst ldl a5
(* 5 n-word-bytes
) vals
)
56 (inst subq nvals
(fixnumize 6) count
)
59 ;; Copy the remaining args to the top of the stack.
60 (inst addq vals
(* 6 n-word-bytes
) vals
)
61 (inst addq cfp-tn
(* 6 n-word-bytes
) dst
)
64 (inst ldl temp
0 vals
)
65 (inst addq vals n-word-bytes vals
)
67 (inst subq count
(fixnumize 1) count
)
68 (inst addq dst n-word-bytes dst
)
71 (inst br zero-tn done
)
74 (inst move null-tn a0
)
75 (inst move null-tn a1
)
77 (inst move null-tn a2
)
79 (inst move null-tn a3
)
81 (inst move null-tn a4
)
83 (inst move null-tn a5
)
89 (inst addq ocfp-tn nvals csp-tn
)
92 (lisp-return lra lip
))
94 ;;;; tail-call-variable
96 #+sb-assembling
;; no vop for this one either
97 (define-assembly-routine
99 (:return-style
:none
))
101 ;; These are really args.
102 ((:temp args any-reg nl0-offset
)
103 (:temp lexenv descriptor-reg lexenv-offset
)
105 ;; We need to compute this
106 (:temp nargs any-reg nargs-offset
)
108 ;; These are needed by the blitting code.
109 (:temp src any-reg nl1-offset
)
110 (:temp dst any-reg nl2-offset
)
111 (:temp count any-reg cfunc-offset
)
112 (:temp temp descriptor-reg l0-offset
)
114 ;; Needed for the jump
115 (:temp lip interior-reg lip-offset
)
117 ;; These are needed so we can get at the register args.
118 (:temp a0 descriptor-reg a0-offset
)
119 (:temp a1 descriptor-reg a1-offset
)
120 (:temp a2 descriptor-reg a2-offset
)
121 (:temp a3 descriptor-reg a3-offset
)
122 (:temp a4 descriptor-reg a4-offset
)
123 (:temp a5 descriptor-reg a5-offset
))
126 ;; Calculate NARGS (as a fixnum)
127 (inst subq csp-tn args nargs
)
129 ;; Load the argument regs (must do this now, 'cause the blt might
130 ;; trash these locations)
131 (inst ldl a0
(* 0 n-word-bytes
) args
)
132 (inst ldl a1
(* 1 n-word-bytes
) args
)
133 (inst ldl a2
(* 2 n-word-bytes
) args
)
134 (inst ldl a3
(* 3 n-word-bytes
) args
)
135 (inst ldl a4
(* 4 n-word-bytes
) args
)
136 (inst ldl a5
(* 5 n-word-bytes
) args
)
138 ;; Calc SRC, DST, and COUNT
139 (inst subq nargs
(fixnumize register-arg-count
) count
)
140 (inst addq args
(* n-word-bytes register-arg-count
) src
)
141 (inst ble count done
)
142 (inst addq cfp-tn
(* n-word-bytes register-arg-count
) dst
)
146 (inst ldl temp
0 src
)
147 (inst addq src n-word-bytes src
)
148 (inst stl temp
0 dst
)
149 (inst subq count
(fixnumize 1) count
)
150 (inst addq dst n-word-bytes dst
)
151 (inst bgt count loop
)
154 ;; We are done. Do the jump.
156 (loadw temp lexenv closure-fun-slot fun-pointer-lowtag
)
157 (lisp-jump temp lip
)))
160 ;;;; non-local exit noise
162 (define-assembly-routine
164 (:translate %continue-unwind
)
165 (:policy
:fast-safe
))
166 ((:arg block
(any-reg descriptor-reg
) a0-offset
)
167 (:arg start
(any-reg descriptor-reg
) ocfp-offset
)
168 (:arg count
(any-reg descriptor-reg
) nargs-offset
)
169 (:temp lip interior-reg lip-offset
)
170 (:temp lra descriptor-reg lra-offset
)
171 (:temp cur-uwp any-reg nl0-offset
)
172 (:temp next-uwp any-reg nl1-offset
)
173 (:temp target-uwp any-reg nl2-offset
)
174 (:temp temp1 non-descriptor-reg nl3-offset
))
175 (declare (ignore start count
))
177 (load-symbol-value cur-uwp
*current-unwind-protect-block
*)
178 (let ((error (generate-error-code nil invalid-unwind-error
)))
179 (inst beq block error
))
181 (loadw target-uwp block unwind-block-current-uwp-slot
)
182 (inst cmpeq cur-uwp target-uwp temp1
)
183 (inst beq temp1 do-uwp
)
189 (loadw cfp-tn cur-uwp unwind-block-current-cont-slot
)
190 (loadw code-tn cur-uwp unwind-block-current-code-slot
)
192 (loadw lra cur-uwp unwind-block-entry-pc-slot
)
193 (lisp-return lra lip
:frob-code nil
))
197 (loadw next-uwp cur-uwp unwind-block-current-uwp-slot
)
198 (store-symbol-value next-uwp
*current-unwind-protect-block
*)
199 (inst br zero-tn do-exit
))
201 (define-assembly-routine
203 ((:arg target descriptor-reg a0-offset
)
204 (:arg start any-reg ocfp-offset
)
205 (:arg count any-reg nargs-offset
)
206 (:temp catch any-reg a1-offset
)
207 (:temp tag descriptor-reg a2-offset
)
208 (:temp temp1 non-descriptor-reg nl0-offset
))
210 (progn start count
) ; We just need them in the registers.
212 (load-symbol-value catch
*current-catch-block
*)
216 (let ((error (generate-error-code nil unseen-throw-tag-error target
)))
217 (inst beq catch error
))
219 (loadw tag catch catch-block-tag-slot
)
220 (inst cmpeq tag target temp1
)
221 (inst bne temp1 exit
)
222 (loadw catch catch catch-block-previous-catch-slot
)
223 (inst br zero-tn loop
)
228 (inst li
(make-fixup 'unwind
:assembly-routine
) temp1
)
229 (inst jmp zero-tn temp1
(make-fixup 'unwind
:assembly-routine
)))