1 ;;; **********************************************************************
2 ;;; This code was written as part of the CMU Common Lisp project at
3 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; **********************************************************************
11 ;;;; Return-multiple with other than one value
13 #+sb-assembling ;; we don't want a vop for this one.
14 (define-assembly-routine
16 (:return-style :none))
18 ;; These four are really arguments.
19 ((:temp nvals any-reg nargs-offset)
20 (:temp vals any-reg nl0-offset)
21 (:temp ocfp any-reg nl1-offset)
22 (:temp lra descriptor-reg lra-offset)
24 ;; These are just needed to facilitate the transfer
25 (:temp lip interior-reg lip-offset)
26 (:temp count any-reg nl2-offset)
27 (:temp dst any-reg nl4-offset)
28 (:temp temp descriptor-reg l0-offset)
30 ;; These are needed so we can get at the register args.
31 (:temp a0 descriptor-reg a0-offset)
32 (:temp a1 descriptor-reg a1-offset)
33 (:temp a2 descriptor-reg a2-offset)
34 (:temp a3 descriptor-reg a3-offset)
35 (:temp a4 descriptor-reg a4-offset)
36 (:temp a5 descriptor-reg a5-offset))
38 ;; Note, because of the way the return-multiple vop is written, we can
39 ;; assume that we are never called with nvals == 1 and that a0 has already
41 (inst ble nvals default-a0-and-on)
42 (inst ldl a1 (* 1 sb!vm:word-bytes) vals)
43 (inst subq nvals (fixnumize 2) count)
44 (inst ble count default-a2-and-on)
45 (inst ldl a2 (* 2 sb!vm:word-bytes) vals)
46 (inst subq nvals (fixnumize 3) count)
47 (inst ble count default-a3-and-on)
48 (inst ldl a3 (* 3 sb!vm:word-bytes) vals)
49 (inst subq nvals (fixnumize 4) count)
50 (inst ble count default-a4-and-on)
51 (inst ldl a4 (* 4 sb!vm:word-bytes) vals)
52 (inst subq nvals (fixnumize 5) count)
53 (inst ble count default-a5-and-on)
54 (inst ldl a5 (* 5 sb!vm:word-bytes) vals)
55 (inst subq nvals (fixnumize 6) count)
58 ;; Copy the remaining args to the top of the stack.
59 (inst addq vals (* 6 sb!vm:word-bytes) vals)
60 (inst addq cfp-tn (* 6 sb!vm:word-bytes) dst)
63 (inst ldl temp 0 vals)
64 (inst addq vals sb!vm:word-bytes vals)
66 (inst subq count (fixnumize 1) count)
67 (inst addq dst sb!vm:word-bytes dst)
70 (inst br zero-tn done)
73 (inst move null-tn a0)
74 (inst move null-tn a1)
76 (inst move null-tn a2)
78 (inst move null-tn a3)
80 (inst move null-tn a4)
82 (inst move null-tn a5)
88 (inst addq ocfp-tn nvals csp-tn)
91 (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 sb!vm:word-bytes) args)
132 (inst ldl a1 (* 1 sb!vm:word-bytes) args)
133 (inst ldl a2 (* 2 sb!vm:word-bytes) args)
134 (inst ldl a3 (* 3 sb!vm:word-bytes) args)
135 (inst ldl a4 (* 4 sb!vm:word-bytes) args)
136 (inst ldl a5 (* 5 sb!vm:word-bytes) args)
138 ;; Calc SRC, DST, and COUNT
139 (inst subq nargs (fixnumize register-arg-count) count)
140 (inst addq args (* sb!vm:word-bytes register-arg-count) src)
141 (inst ble count done)
142 (inst addq cfp-tn (* sb!vm:word-bytes register-arg-count) dst)
146 (inst ldl temp 0 src)
147 (inst addq src sb!vm:word-bytes src)
148 (inst stl temp 0 dst)
149 (inst subq count (fixnumize 1) count)
150 (inst addq dst sb!vm:word-bytes dst)
151 (inst bgt count loop)
154 ;; We are done. Do the jump.
156 (loadw temp lexenv sb!vm:closure-function-slot sb!vm:function-pointer-type)
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 sb!impl::*current-unwind-protect-block*)
178 (let ((error (generate-error-code nil invalid-unwind-error)))
179 (inst beq block error))
181 (loadw target-uwp block sb!vm: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 sb!vm:unwind-block-current-cont-slot)
190 (loadw code-tn cur-uwp sb!vm:unwind-block-current-code-slot)
192 (loadw lra cur-uwp sb!vm:unwind-block-entry-pc-slot)
193 (lisp-return lra lip :frob-code nil))
197 (loadw next-uwp cur-uwp sb!vm:unwind-block-current-uwp-slot)
198 (store-symbol-value next-uwp sb!impl::*current-unwind-protect-block*)
199 (inst br zero-tn do-exit))
202 (define-assembly-routine
204 ((:arg target descriptor-reg a0-offset)
205 (:arg start any-reg ocfp-offset)
206 (:arg count any-reg nargs-offset)
207 (:temp catch any-reg a1-offset)
208 (:temp tag descriptor-reg a2-offset)
209 (:temp temp1 non-descriptor-reg nl0-offset))
211 (progn start count) ; We just need them in the registers.
213 (load-symbol-value catch sb!impl::*current-catch-block*)
217 (let ((error (generate-error-code nil unseen-throw-tag-error target)))
218 (inst beq catch error))
220 (loadw tag catch sb!vm:catch-block-tag-slot)
221 (inst cmpeq tag target temp1)
222 (inst bne temp1 exit)
223 (loadw catch catch sb!vm:catch-block-previous-catch-slot)
224 (inst br zero-tn loop)
229 (inst li (make-fixup 'unwind :assembly-routine) temp1)
230 (inst jmp zero-tn temp1 (make-fixup 'unwind :assembly-routine)))