Truthful error reporting for complicated compile-time type mismatches
[sbcl.git] / src / assembly / alpha / assem-rtns.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
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.
9
10 (in-package "SB!VM")
11 \f
12 ;;;; Return-multiple with other than one value
13
14 #+sb-assembling ;; We don't want a vop for this one.
15 (define-assembly-routine
16     (return-multiple
17      (:return-style :none))
18
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)
24
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)
30
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))
38
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)
57   (inst ble count done)
58
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)
62
63   LOOP
64   (inst ldl temp 0 vals)
65   (inst addq vals n-word-bytes vals)
66   (inst stl temp 0 dst)
67   (inst subq count (fixnumize 1) count)
68   (inst addq dst n-word-bytes dst)
69   (inst bne count loop)
70
71   (inst br zero-tn done)
72
73   DEFAULT-A0-AND-ON
74   (inst move null-tn a0)
75   (inst move null-tn a1)
76   DEFAULT-A2-AND-ON
77   (inst move null-tn a2)
78   DEFAULT-A3-AND-ON
79   (inst move null-tn a3)
80   DEFAULT-A4-AND-ON
81   (inst move null-tn a4)
82   DEFAULT-A5-AND-ON
83   (inst move null-tn a5)
84   DONE
85
86   ;; Clear the stack.
87   (move cfp-tn ocfp-tn)
88   (move ocfp cfp-tn)
89   (inst addq ocfp-tn nvals csp-tn)
90
91   ;; Return.
92   (lisp-return lra lip))
93 \f
94 ;;;; tail-call-variable
95
96 #+sb-assembling ;; no vop for this one either
97 (define-assembly-routine
98     (tail-call-variable
99      (:return-style :none))
100
101     ;; These are really args.
102     ((:temp args any-reg nl0-offset)
103      (:temp lexenv descriptor-reg lexenv-offset)
104
105      ;; We need to compute this
106      (:temp nargs any-reg nargs-offset)
107
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)
113
114      ;; Needed for the jump
115      (:temp lip interior-reg lip-offset)
116
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))
124
125
126   ;; Calculate NARGS (as a fixnum)
127   (inst subq csp-tn args nargs)
128
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)
137
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)
143
144   LOOP
145   ;; Copy one arg.
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)
152
153   DONE
154   ;; We are done.  Do the jump.
155   (progn
156     (loadw temp lexenv closure-fun-slot fun-pointer-lowtag)
157     (lisp-jump temp lip)))
158
159 \f
160 ;;;; non-local exit noise
161
162 (define-assembly-routine
163     (unwind
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))
176
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))
180
181   (loadw target-uwp block unwind-block-current-uwp-slot)
182   (inst cmpeq cur-uwp target-uwp temp1)
183   (inst beq temp1 do-uwp)
184
185   (move block cur-uwp)
186
187   do-exit
188
189   (loadw cfp-tn cur-uwp unwind-block-current-cont-slot)
190   (loadw code-tn cur-uwp unwind-block-current-code-slot)
191   (progn
192     (loadw lra cur-uwp unwind-block-entry-pc-slot)
193     (lisp-return lra lip :frob-code nil))
194
195   do-uwp
196
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))
200
201 (define-assembly-routine
202     throw
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))
209
210   (progn start count) ; We just need them in the registers.
211
212   (load-symbol-value catch *current-catch-block*)
213
214   loop
215
216   (let ((error (generate-error-code nil unseen-throw-tag-error target)))
217     (inst beq catch error))
218
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)
224
225   exit
226
227   (move catch target)
228   (inst li (make-fixup 'unwind :assembly-routine) temp1)
229   (inst jmp zero-tn temp1 (make-fixup 'unwind :assembly-routine)))