1 | ;;; ppc-trap-support |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2009 Clozure Associates |
---|
4 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
5 | ;;; This file is part of Clozure CL. |
---|
6 | ;;; |
---|
7 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public |
---|
8 | ;;; License , known as the LLGPL and distributed with Clozure CL as the |
---|
9 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
10 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
---|
11 | ;;; conflict, the preamble takes precedence. |
---|
12 | ;;; |
---|
13 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY." |
---|
14 | ;;; |
---|
15 | ;;; The LLGPL is also available online at |
---|
16 | ;;; http://opensource.franz.com/preamble.html |
---|
17 | |
---|
18 | ;;; Support for PPC traps, this includes the event-poll trap |
---|
19 | ;;; and all the trxxx traps for type checks & arg count checks. |
---|
20 | |
---|
21 | (in-package "CCL") |
---|
22 | |
---|
23 | (eval-when (:compile-toplevel :execute) |
---|
24 | (require "NUMBER-MACROS") |
---|
25 | |
---|
26 | |
---|
27 | (defparameter *ppc-instruction-fields* |
---|
28 | `((:opcode . ,(byte 6 26)) |
---|
29 | (:rt . ,(byte 5 21)) |
---|
30 | (:to . ,(byte 5 21)) |
---|
31 | (:ra . ,(byte 5 16)) |
---|
32 | (:rb . ,(byte 5 11)) |
---|
33 | (:d . ,(byte 16 0)) |
---|
34 | (:ds . ,(byte 14 2)) |
---|
35 | (:ds-xo . ,(byte 2 0)) |
---|
36 | (:sh . ,(byte 5 11)) |
---|
37 | (:mb . ,(byte 5 6)) |
---|
38 | (:me . ,(byte 5 1)) |
---|
39 | (:mb6 . ,(byte 6 5)) |
---|
40 | (:me6 . ,(byte 6 5)) |
---|
41 | (:sh6 . ,(byte 1 1)) |
---|
42 | (:x-minor . ,(byte 10 1)) |
---|
43 | (:fulltag32 . ,(byte ppc32::ntagbits 0)) |
---|
44 | (:lisptag32 . ,(byte ppc32::nlisptagbits 0)) |
---|
45 | (:fulltag64 . ,(byte ppc64::ntagbits 0)) |
---|
46 | (:lisptag64 . ,(byte ppc64::nlisptagbits 0)) |
---|
47 | (:lowtag64 . ,(byte ppc64::nlowtagbits 0)))) |
---|
48 | |
---|
49 | (defun ppc-instruction-field (field-name) |
---|
50 | (or (cdr (assoc field-name *ppc-instruction-fields*)) |
---|
51 | (error "Unknown PPC instruction field: ~s" field-name))) |
---|
52 | |
---|
53 | (defun ppc-instruction-field-mask (field-spec) |
---|
54 | (let* ((name (if (atom field-spec) field-spec (car field-spec))) |
---|
55 | (value (if (atom field-spec) -1 (cadr field-spec)))) |
---|
56 | (dpb value (ppc-instruction-field name) 0))) |
---|
57 | |
---|
58 | #+darwinppc-target |
---|
59 | (progn |
---|
60 | (def-foreign-type nil |
---|
61 | (:struct :darwin-ppc-float-state |
---|
62 | (:fpregs (:array :double 32)) |
---|
63 | (:fpscr-pad (:unsigned 32)) |
---|
64 | (:fpscr (:unsigned 32)))) |
---|
65 | (def-foreign-type nil |
---|
66 | (:struct :darwin-ppc-vector-state |
---|
67 | (:save-vr (:array (:array (:unsigned 32) 4) 32)) |
---|
68 | (:save-vscr (:array (:unsigned 32) 4)) |
---|
69 | (:save-pad5 (:array (:unsigned 32) 4)) |
---|
70 | (:save-vrvalid (:unsigned 32)) |
---|
71 | (:save-pad6 (:array (:unsigned 32) 7)))) |
---|
72 | #+ppc64-target |
---|
73 | (progn |
---|
74 | (def-foreign-type nil |
---|
75 | (:struct :darwin-ppc-exception-state64 |
---|
76 | (:dar (:unsigned 64)) |
---|
77 | (:dsisr (:unsigned 32)) |
---|
78 | (:exception (:unsigned 32)) |
---|
79 | (:pad1 (:array (:unsigned 32) 4)))) |
---|
80 | (def-foreign-type nil |
---|
81 | ;; The real record type is defined with |
---|
82 | ;; #pragma pack(4) in effect. |
---|
83 | ;; The :struct parser should really accept |
---|
84 | ;; some option to deal with that, but Apple |
---|
85 | ;; should also stop mis-aligning things. |
---|
86 | (:struct :darwin-ppc-thread-state64 |
---|
87 | (:srr0 (:unsigned 64)) |
---|
88 | (:srr1 (:unsigned 64)) |
---|
89 | (:r0 (:unsigned 64)) |
---|
90 | (:r1 (:unsigned 64)) |
---|
91 | (:r2 (:unsigned 64)) |
---|
92 | (:r3 (:unsigned 64)) |
---|
93 | (:r4 (:unsigned 64)) |
---|
94 | (:r5 (:unsigned 64)) |
---|
95 | (:r6 (:unsigned 64)) |
---|
96 | (:r7 (:unsigned 64)) |
---|
97 | (:r8 (:unsigned 64)) |
---|
98 | (:r9 (:unsigned 64)) |
---|
99 | (:r10 (:unsigned 64)) |
---|
100 | (:r11 (:unsigned 64)) |
---|
101 | (:r12 (:unsigned 64)) |
---|
102 | (:r13 (:unsigned 64)) |
---|
103 | (:r14 (:unsigned 64)) |
---|
104 | (:r15 (:unsigned 64)) |
---|
105 | (:r16 (:unsigned 64)) |
---|
106 | (:r17 (:unsigned 64)) |
---|
107 | (:r18 (:unsigned 64)) |
---|
108 | (:r19 (:unsigned 64)) |
---|
109 | (:r20 (:unsigned 64)) |
---|
110 | (:r21 (:unsigned 64)) |
---|
111 | (:r22 (:unsigned 64)) |
---|
112 | (:r23 (:unsigned 64)) |
---|
113 | (:r24 (:unsigned 64)) |
---|
114 | (:r25 (:unsigned 64)) |
---|
115 | (:r26 (:unsigned 64)) |
---|
116 | (:r27 (:unsigned 64)) |
---|
117 | (:r28 (:unsigned 64)) |
---|
118 | (:r29 (:unsigned 64)) |
---|
119 | (:r30 (:unsigned 64)) |
---|
120 | (:r31 (:unsigned 64)) |
---|
121 | (:cr (:unsigned 32)) |
---|
122 | (:xer (:unsigned 32)) |
---|
123 | (:xer-low (:unsigned 32)) |
---|
124 | (:lr (:unsigned 32)) |
---|
125 | (:lr-low (:unsigned 32)) |
---|
126 | (:ctr (:unsigned 32)) |
---|
127 | (:ctr-low (:unsigned 32)) |
---|
128 | (:vrsave (:unsigned 32)))) |
---|
129 | (def-foreign-type nil |
---|
130 | (:struct :darwin-sigaltstack64 |
---|
131 | (:ss-sp (:* :void)) |
---|
132 | (:ss-size (:unsigned 64)) |
---|
133 | (:ss-flags (:unsigned 32)))) |
---|
134 | (def-foreign-type nil |
---|
135 | (:struct :darwin-mcontext64 |
---|
136 | (:es (:struct :darwin-ppc-exception-state64)) |
---|
137 | (:ss (:struct :darwin-ppc-thread-state64)) |
---|
138 | (:fs (:struct :darwin-ppc-float-state)) |
---|
139 | (:vs (:struct :darwin-ppc-vector-state)))) |
---|
140 | (def-foreign-type nil |
---|
141 | (:struct :darwin-ucontext64 |
---|
142 | (:uc-onstack (:signed 32)) |
---|
143 | (:uc-sigmask (:signed 32)) |
---|
144 | (:uc-stack (:struct :darwin-sigaltstack64)) |
---|
145 | (:uc-link (:* (:struct :darwin-ucontext64))) |
---|
146 | (:uc-mcsize (:signed 64)) |
---|
147 | (:uc-mcontext64 (:* (:struct :darwin-mcontext64))))) |
---|
148 | ) |
---|
149 | #+ppc32-target |
---|
150 | (progn |
---|
151 | (def-foreign-type nil |
---|
152 | (:struct :darwin-ppc-exception-state32 |
---|
153 | (:dar (:unsigned 32)) |
---|
154 | (:dsisr (:unsigned 32)) |
---|
155 | (:exception (:unsigned 32)) |
---|
156 | (:pad0 (:unsigned 32)) |
---|
157 | (:pad1 (:array (:unsigned 32) 4)))) |
---|
158 | (def-foreign-type nil |
---|
159 | (:struct :darwin-ppc-thread-state32 |
---|
160 | (:srr0 (:unsigned 32)) |
---|
161 | (:srr1 (:unsigned 32)) |
---|
162 | (:r0 (:unsigned 32)) |
---|
163 | (:r1 (:unsigned 32)) |
---|
164 | (:r2 (:unsigned 32)) |
---|
165 | (:r3 (:unsigned 32)) |
---|
166 | (:r4 (:unsigned 32)) |
---|
167 | (:r5 (:unsigned 32)) |
---|
168 | (:r6 (:unsigned 32)) |
---|
169 | (:r7 (:unsigned 32)) |
---|
170 | (:r8 (:unsigned 32)) |
---|
171 | (:r9 (:unsigned 32)) |
---|
172 | (:r10 (:unsigned 32)) |
---|
173 | (:r11 (:unsigned 32)) |
---|
174 | (:r12 (:unsigned 32)) |
---|
175 | (:r13 (:unsigned 32)) |
---|
176 | (:r14 (:unsigned 32)) |
---|
177 | (:r15 (:unsigned 32)) |
---|
178 | (:r16 (:unsigned 32)) |
---|
179 | (:r17 (:unsigned 32)) |
---|
180 | (:r18 (:unsigned 32)) |
---|
181 | (:r19 (:unsigned 32)) |
---|
182 | (:r20 (:unsigned 32)) |
---|
183 | (:r21 (:unsigned 32)) |
---|
184 | (:r22 (:unsigned 32)) |
---|
185 | (:r23 (:unsigned 32)) |
---|
186 | (:r24 (:unsigned 32)) |
---|
187 | (:r25 (:unsigned 32)) |
---|
188 | (:r26 (:unsigned 32)) |
---|
189 | (:r27 (:unsigned 32)) |
---|
190 | (:r28 (:unsigned 32)) |
---|
191 | (:r29 (:unsigned 32)) |
---|
192 | (:r30 (:unsigned 32)) |
---|
193 | (:r31 (:unsigned 32)) |
---|
194 | (:cr (:unsigned 32)) |
---|
195 | (:xer (:unsigned 32)) |
---|
196 | (:lr (:unsigned 32)) |
---|
197 | (:ctr (:unsigned 32)) |
---|
198 | (:mq (:unsigned 32)) ; ppc 601! |
---|
199 | (:vrsave (:unsigned 32)))) |
---|
200 | (def-foreign-type nil |
---|
201 | (:struct :darwin-sigaltstack32 |
---|
202 | (:ss-sp (:* :void)) |
---|
203 | (:ss-size (:unsigned 32)) |
---|
204 | (:ss-flags (:unsigned 32)))) |
---|
205 | (def-foreign-type nil |
---|
206 | (:struct :darwin-mcontext32 |
---|
207 | (:es (:struct :darwin-ppc-exception-state32)) |
---|
208 | (:ss (:struct :darwin-ppc-thread-state32)) |
---|
209 | (:fs (:struct :darwin-ppc-float-state)) |
---|
210 | (:vs (:struct :darwin-ppc-vector-state)))) |
---|
211 | (def-foreign-type nil |
---|
212 | (:struct :darwin-ucontext32 |
---|
213 | (:uc-onstack (:signed 32)) |
---|
214 | (:uc-sigmask (:signed 32)) |
---|
215 | (:uc-stack (:struct :darwin-sigaltstack32)) |
---|
216 | (:uc-link (:* (:struct :darwin-ucontext32))) |
---|
217 | (:uc-mcsize (:signed 32)) |
---|
218 | (:uc-mcontext32 (:* (:struct :darwin-mcontext32))))) |
---|
219 | ) |
---|
220 | ) |
---|
221 | |
---|
222 | |
---|
223 | |
---|
224 | |
---|
225 | (defmacro with-xp-registers-and-gpr-offset ((xp register-number) (registers offset) &body body) |
---|
226 | (let* ((regform #+linuxppc-target |
---|
227 | `(pref ,xp :ucontext.uc_mcontext.regs) |
---|
228 | #+darwinppc-target |
---|
229 | (target-arch-case |
---|
230 | ;; Gak. Apple gratuitously renamed things |
---|
231 | ;; for Leopard. Hey, it's not as if anyone |
---|
232 | ;; has better things to do than to deal with |
---|
233 | ;; this crap ... |
---|
234 | (:ppc32 `(pref ,xp :darwin-ucontext32.uc-mcontext32.ss)) |
---|
235 | (:ppc64 `(pref ,xp :darwin-ucontext64.uc-mcontext64.ss))))) |
---|
236 | `(with-macptrs ((,registers ,regform)) |
---|
237 | (let ((,offset (xp-gpr-offset ,register-number))) |
---|
238 | ,@body)))) |
---|
239 | |
---|
240 | (defmacro RA-field (instr) |
---|
241 | `(ldb (byte 5 16) ,instr)) |
---|
242 | |
---|
243 | (defmacro RB-field (instr) |
---|
244 | `(ldb (byte 5 11) ,instr)) |
---|
245 | |
---|
246 | (defmacro D-field (instr) |
---|
247 | `(ldb (byte 16 0) ,instr)) |
---|
248 | |
---|
249 | (defmacro RS-field (instr) |
---|
250 | `(ldb (byte 5 21) ,instr)) |
---|
251 | |
---|
252 | (defmacro lisp-reg-p (reg) |
---|
253 | `(>= ,reg ppc::fn)) |
---|
254 | |
---|
255 | (defmacro ppc-lap-word (instruction-form) |
---|
256 | (uvref (uvref (compile nil |
---|
257 | `(lambda (&lap 0) |
---|
258 | (ppc-lap-function () ((?? 0)) |
---|
259 | ,instruction-form))) |
---|
260 | |
---|
261 | 0) #+ppc32-host 0 #+ppc64-host 1)) |
---|
262 | |
---|
263 | (defmacro ppc-instruction-mask (&rest fields) |
---|
264 | `(logior ,@(mapcar #'ppc-instruction-field-mask (cons :opcode fields)))) |
---|
265 | |
---|
266 | ) |
---|
267 | |
---|
268 | |
---|
269 | |
---|
270 | (defun xp-gpr-offset (register-number) |
---|
271 | (unless (and (fixnump register-number) |
---|
272 | (<= -2 (the fixnum register-number)) |
---|
273 | (< (the fixnum register-number) 48)) |
---|
274 | (setq register-number (require-type register-number '(integer -2 48)))) |
---|
275 | (the fixnum |
---|
276 | (* (the fixnum #+linuxppc-target register-number |
---|
277 | #+darwinppc-target (+ register-number 2)) |
---|
278 | target::node-size))) |
---|
279 | |
---|
280 | |
---|
281 | |
---|
282 | (defun xp-gpr-lisp (xp register-number) |
---|
283 | (with-xp-registers-and-gpr-offset (xp register-number) (registers offset) |
---|
284 | (values (%get-object registers offset)))) |
---|
285 | |
---|
286 | (defun (setf xp-gpr-lisp) (value xp register-number) |
---|
287 | (with-xp-registers-and-gpr-offset (xp register-number) (registers offset) |
---|
288 | (%set-object registers offset value))) |
---|
289 | |
---|
290 | (defun xp-gpr-signed-long (xp register-number) |
---|
291 | (with-xp-registers-and-gpr-offset (xp register-number) (registers offset) |
---|
292 | (values (%get-signed-long registers offset)))) |
---|
293 | |
---|
294 | (defun xp-gpr-signed-doubleword (xp register-number) |
---|
295 | (with-xp-registers-and-gpr-offset (xp register-number) (registers offset) |
---|
296 | (values (%%get-signed-longlong registers offset)))) |
---|
297 | |
---|
298 | |
---|
299 | (defun xp-gpr-macptr (xp register-number) |
---|
300 | (with-xp-registers-and-gpr-offset (xp register-number) (registers offset) |
---|
301 | (values (%get-ptr registers offset)))) |
---|
302 | |
---|
303 | (defun xp-argument-list (xp) |
---|
304 | (let ((nargs (xp-gpr-lisp xp ppc::nargs)) ; tagged as a fixnum (how convenient) |
---|
305 | (arg-x (xp-gpr-lisp xp ppc::arg_x)) |
---|
306 | (arg-y (xp-gpr-lisp xp ppc::arg_y)) |
---|
307 | (arg-z (xp-gpr-lisp xp ppc::arg_z))) |
---|
308 | (cond ((eql nargs 0) nil) |
---|
309 | ((eql nargs 1) (list arg-z)) |
---|
310 | ((eql nargs 2) (list arg-y arg-z)) |
---|
311 | (t (let ((args (list arg-x arg-y arg-z))) |
---|
312 | (if (eql nargs 3) |
---|
313 | args |
---|
314 | (let ((vsp (xp-gpr-macptr xp ppc::vsp))) |
---|
315 | (dotimes (i (- nargs 3)) |
---|
316 | (push (%get-object vsp (* i target::node-size)) args)) |
---|
317 | args))))))) |
---|
318 | |
---|
319 | (defun xp-fpscr-info (xp) |
---|
320 | (let* ((fpscr #+(and linuxppc-target 32-bit-target) (%get-unsigned-long (pref xp :ucontext.uc_mcontext.regs) (ash #$PT_FPSCR 2)) |
---|
321 | #+(and linuxppc-target 64-bit-target) |
---|
322 | (%get-unsigned-long (pref xp :ucontext.uc_mcontext.fp_regs) (ash 65 2)) |
---|
323 | #+(and darwinppc-target ppc32-target) |
---|
324 | (pref xp :darwin-ucontext32.uc-mcontext32.fs.fpscr) |
---|
325 | #+(and darwinppc-target ppc64-target) |
---|
326 | (pref xp :darwin-ucontext64.uc-mcontext64.fs.fpscr))) |
---|
327 | (values (ldb (byte 24 8) fpscr) (ldb (byte 8 0) fpscr)))) |
---|
328 | |
---|
329 | #+linuxppc-target |
---|
330 | (defun xp-double-float (xp fpr) |
---|
331 | #+32-bit-target |
---|
332 | (%get-double-float (pref xp :ucontext.uc_mcontext.regs) (+ (ash #$PT_FPR0 2) (ash fpr 3))) |
---|
333 | #+64-bit-target |
---|
334 | (%get-double-float (pref xp :ucontext.uc_mcontext.fp_regs) (ash fpr 3)) |
---|
335 | ) |
---|
336 | |
---|
337 | #+darwinppc-target |
---|
338 | (defun xp-double-float (xp fpr) |
---|
339 | (%get-double-float |
---|
340 | #+ppc32-target (pref xp :darwin-ucontext32.uc-mcontext32.fs) |
---|
341 | #+ppc64-target (pref xp :darwin-ucontext64.uc-mcontext64.fs) |
---|
342 | (ash fpr 3))) |
---|
343 | |
---|
344 | |
---|
345 | (defparameter *trap-lookup-tries* 5) |
---|
346 | |
---|
347 | |
---|
348 | |
---|
349 | (defun %scan-for-instr (mask opcode fn pc-index tries) |
---|
350 | (let ((code-vector (and fn (uvref fn 0))) |
---|
351 | (offset 0)) |
---|
352 | (declare (fixnum offset)) |
---|
353 | (flet ((get-instr () |
---|
354 | (if code-vector |
---|
355 | (let ((index (+ pc-index offset))) |
---|
356 | (when (< index 0) (return-from %scan-for-instr nil)) |
---|
357 | (uvref code-vector index)) |
---|
358 | (%get-long pc-index (the fixnum (* 4 offset)))))) |
---|
359 | (declare (dynamic-extent #'get-instr)) |
---|
360 | (dotimes (i tries) |
---|
361 | (decf offset) |
---|
362 | (let ((instr (get-instr))) |
---|
363 | (when (match-instr instr mask opcode) |
---|
364 | (return instr)) |
---|
365 | (when (codevec-header-p instr) |
---|
366 | (return nil))))))) |
---|
367 | |
---|
368 | |
---|
369 | |
---|
370 | |
---|
371 | |
---|
372 | |
---|
373 | (defun return-address-offset (xp fn machine-state-offset) |
---|
374 | (with-macptrs ((regs (pref xp #+linuxppc-target :ucontext.uc_mcontext.regs |
---|
375 | #+(and darwinppc-target ppc32-target) |
---|
376 | :darwin-ucontext32.uc-mcontext32 |
---|
377 | #+(and darwinppc-target ppc64-target) |
---|
378 | :darwin-ucontext64.uc-mcontext64))) |
---|
379 | (if (functionp fn) |
---|
380 | (or (%code-vector-pc (uvref fn 0) (%inc-ptr regs machine-state-offset)) |
---|
381 | (%get-ptr regs machine-state-offset)) |
---|
382 | (%get-ptr regs machine-state-offset)))) |
---|
383 | |
---|
384 | (defconstant lr-offset-in-register-context |
---|
385 | #+linuxppc-target (ash #$PT_LNK target::word-shift) |
---|
386 | #+(and darwinppc-target ppc32-target) |
---|
387 | (+ (get-field-offset :darwin-mcontext32.ss) |
---|
388 | (get-field-offset :darwin-ppc-thread-state32.lr)) |
---|
389 | #+(and darwinppc-target ppc64-target) |
---|
390 | (+ (get-field-offset :darwin-mcontext64.ss) |
---|
391 | (get-field-offset :darwin-ppc-thread-state64.lr))) |
---|
392 | |
---|
393 | (defconstant pc-offset-in-register-context |
---|
394 | #+linuxppc-target (ash #$PT_NIP target::word-shift) |
---|
395 | #+(and darwinppc-target ppc32-target) |
---|
396 | (+ (get-field-offset :darwin-mcontext32.ss) |
---|
397 | (get-field-offset :darwin-ppc-thread-state32.srr0)) |
---|
398 | #+(and darwinppc-target ppc64-target) |
---|
399 | (+ (get-field-offset :darwin-mcontext64.ss) |
---|
400 | (get-field-offset :darwin-ppc-thread-state64.srr0))) |
---|
401 | |
---|
402 | ;;; When a trap happens, we may have not yet created control |
---|
403 | ;;; stack frames for the functions containing PC & LR. |
---|
404 | ;;; If that is the case, we add fake-stack-frame's to *fake-stack-frames* |
---|
405 | ;;; There are 4 cases: |
---|
406 | ;;; |
---|
407 | ;;; PC in FN |
---|
408 | ;;; Push 1 stack frame: PC/FN |
---|
409 | ;;; This might miss one recursive call, but it won't miss any variables |
---|
410 | ;;; PC in NFN |
---|
411 | ;;; Push 2 stack frames: |
---|
412 | ;;; 1) PC/NFN/VSP |
---|
413 | ;;; 2) LR/FN/VSP |
---|
414 | ;;; This might think some of NFN's variables are part of FN's stack frame, |
---|
415 | ;;; but that's the best we can do. |
---|
416 | ;;; LR in FN |
---|
417 | ;;; Push 1 stack frame: LR/FN |
---|
418 | ;;; None of the above |
---|
419 | ;;; Push no new stack frames |
---|
420 | ;;; |
---|
421 | ;;; The backtrace support functions in "ccl:l1;l1-lisp-threads.lisp" know how |
---|
422 | ;;; to find the fake stack frames and handle them as arguments. |
---|
423 | (defun funcall-with-xp-stack-frames (xp trap-function thunk) |
---|
424 | (cond ((null trap-function) |
---|
425 | ; Maybe inside a subprim from a lisp function |
---|
426 | (let* ((fn (xp-gpr-lisp xp ppc::fn)) |
---|
427 | (lr (return-address-offset |
---|
428 | xp fn lr-offset-in-register-context))) |
---|
429 | (if (fixnump lr) |
---|
430 | (let* ((sp (xp-gpr-lisp xp ppc::sp)) |
---|
431 | (vsp (xp-gpr-lisp xp ppc::vsp)) |
---|
432 | (frame (%cons-fake-stack-frame sp sp fn lr vsp xp *fake-stack-frames*)) |
---|
433 | (*fake-stack-frames* frame)) |
---|
434 | (declare (dynamic-extent frame)) |
---|
435 | (funcall thunk frame)) |
---|
436 | (funcall thunk (xp-gpr-lisp xp ppc::sp))))) |
---|
437 | ((eq trap-function (xp-gpr-lisp xp ppc::fn)) |
---|
438 | (let* ((sp (xp-gpr-lisp xp ppc::sp)) |
---|
439 | (fn trap-function) |
---|
440 | (lr (return-address-offset |
---|
441 | xp fn pc-offset-in-register-context)) |
---|
442 | (vsp (xp-gpr-lisp xp ppc::vsp)) |
---|
443 | (frame (%cons-fake-stack-frame sp sp fn lr vsp xp *fake-stack-frames*)) |
---|
444 | (*fake-stack-frames* frame)) |
---|
445 | (declare (dynamic-extent frame)) |
---|
446 | (funcall thunk frame))) |
---|
447 | ((eq trap-function (xp-gpr-lisp xp ppc::nfn)) |
---|
448 | (let* ((sp (xp-gpr-lisp xp ppc::sp)) |
---|
449 | (fn (xp-gpr-lisp xp ppc::fn)) |
---|
450 | (lr (return-address-offset |
---|
451 | xp fn lr-offset-in-register-context)) |
---|
452 | (vsp (xp-gpr-lisp xp ppc::vsp)) |
---|
453 | (lr-frame (%cons-fake-stack-frame sp sp fn lr vsp xp)) |
---|
454 | (pc-fn trap-function) |
---|
455 | (pc-lr (return-address-offset |
---|
456 | xp pc-fn pc-offset-in-register-context)) |
---|
457 | (pc-frame (%cons-fake-stack-frame sp lr-frame pc-fn pc-lr vsp xp *fake-stack-frames*)) |
---|
458 | (*fake-stack-frames* pc-frame)) |
---|
459 | (declare (dynamic-extent lr-frame pc-frame)) |
---|
460 | (funcall thunk pc-frame))) |
---|
461 | (t (funcall thunk (xp-gpr-lisp xp ppc::sp))))) |
---|
462 | |
---|
463 | |
---|
464 | |
---|
465 | ;;; Enter here from handle-trap in "lisp-exceptions.c". |
---|
466 | ;;; xp is a pointer to an ExceptionInformationPowerPC record. |
---|
467 | ;;; the-trap is the trap instruction that got us here. |
---|
468 | ;;; fn-reg is either fn, nfn or 0. If it is fn or nfn, then |
---|
469 | ;;; the trap occcurred in that register's code vector. |
---|
470 | ;;; If it is 0, then the trap occurred somewhere else. |
---|
471 | ;;; pc-index is either the index in fn-reg's code vector |
---|
472 | ;;; or, if fn-reg is 0, the address of the PC at the trap instruction. |
---|
473 | ;;; This code parallels the trap decoding code in |
---|
474 | ;;; "lisp-exceptions.c" that runs if (symbol-value 'cmain) |
---|
475 | ;;; is not a macptr. |
---|
476 | ;;; Some of these could probably call %err-disp instead of error, |
---|
477 | ;;; but I was too lazy to look them up. |
---|
478 | |
---|
479 | #+ppc32-target |
---|
480 | (defcallback xcmain (:without-interrupts t |
---|
481 | :address xp |
---|
482 | :unsigned-fullword fn-reg |
---|
483 | :address pc-or-index |
---|
484 | :unsigned-fullword the-trap |
---|
485 | :signed-fullword arg-0 |
---|
486 | :signed-fullword arg-1) |
---|
487 | ;; twgti nargs,0 |
---|
488 | ;; time for event polling. |
---|
489 | ;; This used to happen a lot so we test for it first. |
---|
490 | (let ((fn (unless (eql fn-reg 0) (xp-gpr-lisp xp fn-reg)))) |
---|
491 | (with-xp-stack-frames (xp fn frame-ptr) |
---|
492 | (if (eql the-trap (ppc-lap-word (twgti nargs 0))) |
---|
493 | (cmain) |
---|
494 | (with-error-reentry-detection |
---|
495 | (let ((pc-index (if (eql fn-reg 0) pc-or-index (%ptr-to-int pc-or-index))) |
---|
496 | instr ra temp rs condition) |
---|
497 | (cond |
---|
498 | ((= the-trap #$SIGBUS) |
---|
499 | (%error (make-condition 'invalid-memory-access |
---|
500 | :address arg-0 |
---|
501 | :write-p (not (zerop arg-1))) |
---|
502 | () |
---|
503 | frame-ptr)) |
---|
504 | ;; tweqi RA nil-value - resolve-eep, or resolve-foreign-variable |
---|
505 | ((and (match-instr the-trap |
---|
506 | (ppc-instruction-mask :opcode :to :d) |
---|
507 | (ppc-lap-word (tweqi ?? (target-nil-value)))) |
---|
508 | (setq instr (scan-for-instr |
---|
509 | (ppc-instruction-mask :opcode :d) |
---|
510 | (ppc-lap-word (lwz ?? |
---|
511 | (+ 4 ppc32::misc-data-offset) |
---|
512 | ??)) |
---|
513 | fn pc-index))) |
---|
514 | (let* ((eep-or-fv (xp-gpr-lisp xp (RA-field instr)))) |
---|
515 | (etypecase eep-or-fv |
---|
516 | (external-entry-point |
---|
517 | (resolve-eep eep-or-fv) |
---|
518 | (setf (xp-gpr-lisp xp (RA-field the-trap)) |
---|
519 | (eep.address eep-or-fv))) |
---|
520 | (foreign-variable |
---|
521 | (resolve-foreign-variable eep-or-fv) |
---|
522 | (setf (xp-gpr-lisp xp (RA-field the-trap)) |
---|
523 | (fv.addr eep-or-fv)))))) |
---|
524 | ;; twnei RA,N; RA = nargs |
---|
525 | ;; nargs check, no optional or rest involved |
---|
526 | ((match-instr the-trap |
---|
527 | (ppc-instruction-mask :opcode :to :ra) |
---|
528 | (ppc-lap-word (twnei nargs ??))) |
---|
529 | (%error (if (< (xp-GPR-signed-long xp ppc::nargs) (D-field the-trap)) |
---|
530 | 'too-few-arguments |
---|
531 | 'too-many-arguments ) |
---|
532 | (list :nargs (ash (xp-GPR-signed-long xp ppc::nargs) |
---|
533 | (- ppc32::fixnumshift)) |
---|
534 | :fn fn) |
---|
535 | frame-ptr)) |
---|
536 | |
---|
537 | ;; twnei RA,N; RA != nargs, N = fulltag_node/immheader |
---|
538 | ;; type check; look for "lbz rt-imm,-3(ra-node)" |
---|
539 | ((and (or (match-instr the-trap |
---|
540 | (ppc-instruction-mask :opcode :to :fulltag32) |
---|
541 | (ppc-lap-word (twnei ?? ppc32::fulltag-nodeheader))) |
---|
542 | (match-instr the-trap |
---|
543 | (ppc-instruction-mask :opcode :to :fulltag32) |
---|
544 | (ppc-lap-word (twnei ?? ppc32::fulltag-immheader)))) |
---|
545 | (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) |
---|
546 | (ppc-lap-word (lbz ?? ppc32::misc-subtag-offset ??)) |
---|
547 | fn pc-index)) |
---|
548 | (lisp-reg-p (setq ra (RA-field instr)))) |
---|
549 | (let* ((typecode (D-field the-trap)) |
---|
550 | (type-tag (logand typecode ppc32::fulltagmask)) |
---|
551 | (type-name (svref (if (eql type-tag ppc32::fulltag-nodeheader) |
---|
552 | *nodeheader-types* |
---|
553 | *immheader-types*) |
---|
554 | (ldb (byte (- ppc32::num-subtag-bits ppc32::ntagbits) ppc32::ntagbits) typecode)))) |
---|
555 | (%error (make-condition 'type-error |
---|
556 | :format-control (%rsc-string $XWRONGTYPE) |
---|
557 | :datum (xp-GPR-lisp xp ra) |
---|
558 | :expected-type type-name) |
---|
559 | nil |
---|
560 | frame-ptr))) |
---|
561 | |
---|
562 | ;; twnei RA,N; RA != nargs, N = subtag_character |
---|
563 | ;; type check; look for "clrlwi rs-node,ra-imm,24" = "rlwinm rs,ra,0,24,31" |
---|
564 | ((and (match-instr the-trap |
---|
565 | (ppc-instruction-mask :opcode :to :d) |
---|
566 | (ppc-lap-word (twnei ?? ppc32::subtag-character))) |
---|
567 | (setq instr (scan-for-instr (ppc-instruction-mask :opcode :rb :mb :me) |
---|
568 | (ppc-lap-word (rlwinm ?? ?? 0 24 31)) |
---|
569 | fn pc-index)) |
---|
570 | (lisp-reg-p (setq rs (RS-field instr)))) |
---|
571 | (%error (make-condition 'type-error |
---|
572 | :datum (xp-GPR-lisp xp rs) |
---|
573 | :expected-type 'character) |
---|
574 | nil |
---|
575 | frame-ptr)) |
---|
576 | |
---|
577 | ;; twnei RA,N; RA != nargs, N != fulltag_node/immheader |
---|
578 | ;; (since that case was handled above.) |
---|
579 | ;; type check; look for "clrlwi rs-node,ra-imm,29/30" = "rlwinm rs,ra,0,29/30,31" |
---|
580 | ((and (match-instr the-trap |
---|
581 | (ppc-instruction-mask :opcode :to) |
---|
582 | (ppc-lap-word (twnei ?? ??))) |
---|
583 | (setq instr (scan-for-instr (ppc-instruction-mask :opcode :rb (:mb 28) :me) |
---|
584 | (ppc-lap-word (rlwinm ?? ?? 0 28 31)) |
---|
585 | fn pc-index)) |
---|
586 | (or (eql (- 32 ppc32::ntagbits) (setq temp (ldb #.(ppc-instruction-field :mb) instr))) |
---|
587 | (eql (- 32 ppc32::nlisptagbits) temp)) |
---|
588 | (lisp-reg-p (setq rs (RS-field instr)))) |
---|
589 | (let* ((tag (logand the-trap ppc32::tagmask)) |
---|
590 | (type-name |
---|
591 | (case tag |
---|
592 | (#.ppc32::tag-fixnum 'fixnum) |
---|
593 | (#.ppc32::tag-list (if (eql temp (- 32 ppc32::ntagbits)) 'cons 'list)) |
---|
594 | (#.ppc32::tag-misc 'uvector) |
---|
595 | (#.ppc32::tag-imm 'immediate)))) |
---|
596 | (%error (make-condition 'type-error |
---|
597 | :datum (xp-GPR-lisp xp rs) |
---|
598 | :expected-type type-name) |
---|
599 | nil |
---|
600 | frame-ptr))) |
---|
601 | |
---|
602 | ;; twlgti RA,N; RA = nargs (xy = 01) |
---|
603 | ;; twllti RA,N; RA = nargs (xy = 10) |
---|
604 | ;; nargs check, optional or rest involved |
---|
605 | ((and (match-instr the-trap |
---|
606 | (ppc-instruction-mask :opcode (:to #x1c) :ra) |
---|
607 | (ppc-lap-word (twi ?? ppc::nargs ??))) |
---|
608 | (or (eql #b01 (setq temp (ldb #.(ppc-instruction-field :to) the-trap))) |
---|
609 | (eql #b10 temp))) |
---|
610 | (%error (if (eql temp #b10) |
---|
611 | 'too-few-arguments |
---|
612 | 'too-many-arguments) |
---|
613 | (list :nargs (ash (xp-GPR-signed-long xp ppc::nargs) |
---|
614 | (- ppc32::fixnumshift)) |
---|
615 | :fn fn) |
---|
616 | frame-ptr)) |
---|
617 | |
---|
618 | ;; tweqi RA,N; N = unbound |
---|
619 | ;; symeval boundp check; look for "lwz RA,symbol.vcell(nodereg)" |
---|
620 | ((and (match-instr the-trap |
---|
621 | (ppc-instruction-mask :opcode :to :d) |
---|
622 | (ppc-lap-word (tweqi ?? ppc32::unbound-marker))) |
---|
623 | (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) |
---|
624 | (ppc-lap-word (lwz ?? ppc32::symbol.vcell ??)) |
---|
625 | fn pc-index)) |
---|
626 | (lisp-reg-p (setq ra (RA-field instr)))) |
---|
627 | (setf (xp-GPR-lisp xp (RA-field the-trap)) |
---|
628 | (%kernel-restart-internal $xvunbnd (list (xp-GPR-lisp xp ra)) frame-ptr))) |
---|
629 | ;; tweqi RA,N: n = (%slot-unbound-marker) |
---|
630 | ;; slot-unbound trap. Look for preceding "lwzx RA,rx,ry". |
---|
631 | ;; rx = slots-vector, ry = scaled index in slots vector. |
---|
632 | ((and (match-instr the-trap |
---|
633 | (ppc-instruction-mask :opcode :to :d) |
---|
634 | (ppc-lap-word (tweqi ?? ppc32::slot-unbound-marker))) |
---|
635 | (setq instr (scan-for-instr (ppc-instruction-mask |
---|
636 | :opcode :rt :x-minor) |
---|
637 | (dpb |
---|
638 | (RA-field the-trap) |
---|
639 | (byte 5 21) |
---|
640 | (ppc-lap-word |
---|
641 | (lwzx ?? ?? ??))) |
---|
642 | fn pc-index))) |
---|
643 | (setq *error-reentry-count* 0) ; succesfully reported error |
---|
644 | |
---|
645 | ;; %SLOT-UNBOUND-TRAP will decode the arguments further, |
---|
646 | ;; then call the generic function SLOT-UNBOUND. That |
---|
647 | ;; might return a value; if so, set the value of the |
---|
648 | ;; register that caused the trap to that value. |
---|
649 | (setf (xp-gpr-lisp xp (ra-field the-trap)) |
---|
650 | (%slot-unbound-trap (xp-gpr-lisp xp (RA-field instr)) |
---|
651 | (ash (- (xp-gpr-signed-long xp (RB-field instr)) |
---|
652 | ppc32::misc-data-offset) |
---|
653 | (- ppc32::word-shift)) |
---|
654 | frame-ptr))) |
---|
655 | ;; twlge RA,RB |
---|
656 | ;; vector bounds check; look for "lwz immreg, misc_header_offset(nodereg)" |
---|
657 | ((and (match-instr the-trap |
---|
658 | (ppc-instruction-mask :opcode :to :x-minor) |
---|
659 | (ppc-lap-word (twlge 0 0))) |
---|
660 | (setq instr (scan-for-instr (ppc-instruction-mask :opcode #|:d|#) |
---|
661 | (ppc-lap-word (lwz ?? ?? #|ppc32::misc-header-offset|# ??)) |
---|
662 | fn pc-index)) |
---|
663 | (lisp-reg-p (setq ra (RA-field instr)))) |
---|
664 | (%error (%rsc-string $xarroob) |
---|
665 | (list (xp-GPR-lisp xp (RA-field the-trap)) |
---|
666 | (xp-GPR-lisp xp ra)) |
---|
667 | frame-ptr)) |
---|
668 | ;; twi 27 ra d - array header rank check |
---|
669 | ((and (match-instr the-trap |
---|
670 | (ppc-instruction-mask :opcode :to) |
---|
671 | (ppc-lap-word (twi 27 ?? ??))) |
---|
672 | (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) |
---|
673 | (ppc-lap-word (lwz ?? ppc32::arrayH.rank ??)) |
---|
674 | fn pc-index)) |
---|
675 | (lisp-reg-p (setq ra (RA-field instr)))) |
---|
676 | (%error (%rsc-string $xndims) |
---|
677 | (list (xp-gpr-lisp xp ra) |
---|
678 | (ash (ldb (byte 16 0) the-trap) (- ppc32::fixnumshift))) |
---|
679 | frame-ptr)) |
---|
680 | ;; tw 27 ra rb - array flags check |
---|
681 | ((and (match-instr the-trap |
---|
682 | (ppc-instruction-mask :opcode :to :x-minor) |
---|
683 | (ppc-lap-word (tw 27 ?? ??))) |
---|
684 | (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) |
---|
685 | (ppc-lap-word (lwz ?? ppc32::arrayH.flags ??)) |
---|
686 | fn pc-index)) |
---|
687 | (lisp-reg-p (setq ra (RA-field instr))) |
---|
688 | (let* ((expected (xp-gpr-lisp xp (RB-field the-trap))) |
---|
689 | (expected-subtype (ldb |
---|
690 | ppc32::arrayH.flags-cell-subtag-byte |
---|
691 | expected)) |
---|
692 | (expect-simple (= |
---|
693 | (ldb ppc32::arrayH.flags-cell-bits-byte |
---|
694 | expected) |
---|
695 | (ash 1 $arh_simple_bit))) |
---|
696 | (type-name |
---|
697 | (case expected-subtype |
---|
698 | (#.ppc32::subtag-double-float-vector 'double-float)))) |
---|
699 | |
---|
700 | (and type-name expect-simple |
---|
701 | (setq condition |
---|
702 | (make-condition 'type-error |
---|
703 | :datum (xp-gpr-lisp xp ra) |
---|
704 | :expected-type |
---|
705 | `(simple-array ,type-name)))))) |
---|
706 | (%error condition nil frame-ptr)) |
---|
707 | |
---|
708 | ;; Unknown trap |
---|
709 | (t (%error "Unknown trap: #x~x~%xp: ~s, fn: ~s, pc: #x~x" |
---|
710 | (list the-trap xp fn (ash pc-index ppc32::fixnumshift)) |
---|
711 | frame-ptr))))))))) |
---|
712 | |
---|
713 | #+ppc64-target |
---|
714 | (defcallback xcmain (:without-interrupts t |
---|
715 | :address xp |
---|
716 | :unsigned-fullword fn-reg |
---|
717 | :address pc-or-index |
---|
718 | :unsigned-fullword the-trap |
---|
719 | :signed-doubleword arg0 |
---|
720 | :signed-doubleword arg1) |
---|
721 | ;; tdgti nargs,0 |
---|
722 | ;; time for event polling. |
---|
723 | ;; This used to happen a lot so we test for it first. |
---|
724 | (let ((fn (unless (eql fn-reg 0) (xp-gpr-lisp xp fn-reg)))) |
---|
725 | (with-xp-stack-frames (xp fn frame-ptr) |
---|
726 | (if (eql the-trap (ppc-lap-word (tdgti nargs 0))) |
---|
727 | (cmain) |
---|
728 | (with-error-reentry-detection |
---|
729 | (let ((pc-index (if (eql fn-reg 0) pc-or-index (%ptr-to-int pc-or-index))) |
---|
730 | instr ra temp rs condition) |
---|
731 | (cond |
---|
732 | ;; tdeqi RA nil-value - resolve-eep, or resolve-foreign-variable |
---|
733 | ((and (match-instr the-trap |
---|
734 | (ppc-instruction-mask :opcode :to :d) |
---|
735 | (ppc-lap-word (tdeqi ?? (target-nil-value)))) |
---|
736 | (setq instr (scan-for-instr |
---|
737 | (ppc-instruction-mask :opcode :ds :ds-xo) |
---|
738 | (ppc-lap-word (ld ?? |
---|
739 | (+ 8 ppc64::misc-data-offset) |
---|
740 | ??)) |
---|
741 | fn pc-index))) |
---|
742 | (let* ((eep-or-fv (xp-gpr-lisp xp (RA-field instr)))) |
---|
743 | (etypecase eep-or-fv |
---|
744 | (external-entry-point |
---|
745 | (resolve-eep eep-or-fv) |
---|
746 | (setf (xp-gpr-lisp xp (RA-field the-trap)) |
---|
747 | (eep.address eep-or-fv))) |
---|
748 | (foreign-variable |
---|
749 | (resolve-foreign-variable eep-or-fv) |
---|
750 | (setf (xp-gpr-lisp xp (RA-field the-trap)) |
---|
751 | (fv.addr eep-or-fv)))))) |
---|
752 | ((= the-trap #$SIGBUS) |
---|
753 | (%error (make-condition 'invalid-memory-access |
---|
754 | :address arg0 |
---|
755 | :write-p (not (zerop arg1))) |
---|
756 | () |
---|
757 | frame-ptr)) |
---|
758 | ;; tdnei RA,N; RA = nargs |
---|
759 | ;; nargs check, no optional or rest involved |
---|
760 | ((match-instr the-trap |
---|
761 | (ppc-instruction-mask :opcode :to :ra) |
---|
762 | (ppc-lap-word (tdnei nargs ??))) |
---|
763 | (%error (if (< (xp-GPR-signed-doubleword xp ppc::nargs) (D-field the-trap)) |
---|
764 | 'too-few-arguments |
---|
765 | 'too-many-arguments ) |
---|
766 | (list :nargs (ash (xp-GPR-signed-doubleword xp ppc::nargs) |
---|
767 | (- ppc64::fixnumshift)) |
---|
768 | :fn fn) |
---|
769 | frame-ptr)) |
---|
770 | |
---|
771 | ;; tdnei RA,N; RA != nargs, N = lowtag_node/immheader |
---|
772 | ;; type check; look for "lbz rt-imm,-5(ra-node)" |
---|
773 | ((and (or (match-instr the-trap |
---|
774 | (ppc-instruction-mask :opcode :to :lowtag64) |
---|
775 | (ppc-lap-word (tdnei ?? ppc64::lowtag-nodeheader))) |
---|
776 | (match-instr the-trap |
---|
777 | (ppc-instruction-mask :opcode :rt :lowtag64) |
---|
778 | (ppc-lap-word (tdnei ?? ppc64::lowtag-immheader)))) |
---|
779 | (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) |
---|
780 | (ppc-lap-word (lbz ?? ppc64::misc-subtag-offset ??)) |
---|
781 | fn pc-index)) |
---|
782 | (lisp-reg-p (setq ra (RA-field instr)))) |
---|
783 | (let* ((typecode (D-field the-trap)) |
---|
784 | (type-tag (logand typecode ppc64::lowtagmask)) |
---|
785 | (type-name (svref (if (eql type-tag ppc64::lowtag-nodeheader) |
---|
786 | *nodeheader-types* |
---|
787 | *immheader-types*) |
---|
788 | (ash typecode (- ppc64::nlowtagbits))))) |
---|
789 | (%error (make-condition 'type-error |
---|
790 | :format-control (%rsc-string $XWRONGTYPE) |
---|
791 | :datum (xp-GPR-lisp xp ra) |
---|
792 | :expected-type type-name) |
---|
793 | nil |
---|
794 | frame-ptr))) |
---|
795 | ;; tdnei RA,N; RA != nargs, N = subtag_character type |
---|
796 | ;; check; look for "clrldi rs-node,ra-imm,56" = "rldicl |
---|
797 | ;; rs,ra,0,55" |
---|
798 | ((and (match-instr the-trap |
---|
799 | (ppc-instruction-mask :opcode :rt :d) |
---|
800 | (ppc-lap-word (tdnei ?? ppc64::subtag-character))) |
---|
801 | (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) |
---|
802 | (ppc-lap-word (rldicl ?? ?? 0 56)) |
---|
803 | fn pc-index)) |
---|
804 | (lisp-reg-p (setq rs (RS-field instr)))) |
---|
805 | (%error (make-condition 'type-error |
---|
806 | :datum (xp-GPR-lisp xp rs) |
---|
807 | :expected-type 'character) |
---|
808 | nil |
---|
809 | frame-ptr)) |
---|
810 | |
---|
811 | ;; tdnei RA,N; RA != nargs, N = ppc64::tag-fixnum. type |
---|
812 | ;; check; look for "clrldi rs-node,ra-imm,61" = "rldicl |
---|
813 | ;; rs,ra,61" |
---|
814 | ((and (match-instr the-trap |
---|
815 | (ppc-instruction-mask :opcode :rt) |
---|
816 | (ppc-lap-word (tdnei ?? ppc64::tag-fixnum))) |
---|
817 | (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) |
---|
818 | (ppc-lap-word (rldicl ?? ?? 0 61)) |
---|
819 | fn pc-index)) |
---|
820 | |
---|
821 | (lisp-reg-p (setq rs (RS-field instr)))) |
---|
822 | (%error (make-condition 'type-error |
---|
823 | :datum (xp-GPR-lisp xp rs) |
---|
824 | :expected-type 'fixnum) |
---|
825 | nil |
---|
826 | frame-ptr)) |
---|
827 | ;; tdi 3,RA,ppc64::fulltag-cons; RA != nargs type check; |
---|
828 | ;; look for "clrldi rs-node,ra-imm,60" = "rldicl |
---|
829 | ;; rs,ra,60" |
---|
830 | ((and (match-instr the-trap |
---|
831 | (ppc-instruction-mask :opcode :to :d) |
---|
832 | (ppc-lap-word (tdi 3 ?? ppc64::fulltag-cons))) |
---|
833 | (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) |
---|
834 | (ppc-lap-word (rldicl ?? ?? 0 60)) |
---|
835 | fn pc-index)) |
---|
836 | |
---|
837 | (lisp-reg-p (setq rs (RS-field instr)))) |
---|
838 | (%error (make-condition 'type-error |
---|
839 | :datum (xp-GPR-lisp xp rs) |
---|
840 | :expected-type 'list) |
---|
841 | nil |
---|
842 | frame-ptr)) |
---|
843 | ;; tdnei RA,ppc64::fulltag-cons; RA != nargs type check; |
---|
844 | ;; look for "clrldi rs-node,ra-imm,60" = "rldicl |
---|
845 | ;; rs,ra,60" |
---|
846 | ((and (match-instr the-trap |
---|
847 | (ppc-instruction-mask :opcode :to :d) |
---|
848 | (ppc-lap-word (tdnei ?? ppc64::fulltag-cons))) |
---|
849 | (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) |
---|
850 | (ppc-lap-word (rldicl ?? ?? 0 60)) |
---|
851 | fn pc-index)) |
---|
852 | |
---|
853 | (lisp-reg-p (setq rs (RS-field instr)))) |
---|
854 | (%error (make-condition 'type-error |
---|
855 | :datum (xp-GPR-lisp xp rs) |
---|
856 | :expected-type 'cons) |
---|
857 | nil |
---|
858 | frame-ptr)) |
---|
859 | ;; tdnei RA,ppc64::subtag-single-float; RA != nargs type check; |
---|
860 | ;; look for "clrldi rs-node,ra-imm,60" = "rldicl |
---|
861 | ;; rs,ra,60" |
---|
862 | ((and (match-instr the-trap |
---|
863 | (ppc-instruction-mask :opcode :to :d) |
---|
864 | (ppc-lap-word (tdnei ?? ppc64::subtag-single-float))) |
---|
865 | (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) |
---|
866 | (ppc-lap-word (rldicl ?? ?? 0 60)) |
---|
867 | fn pc-index)) |
---|
868 | |
---|
869 | (lisp-reg-p (setq rs (RS-field instr)))) |
---|
870 | (%error (make-condition 'type-error |
---|
871 | :datum (xp-GPR-lisp xp rs) |
---|
872 | :expected-type 'short-float) |
---|
873 | nil |
---|
874 | frame-ptr)) |
---|
875 | ;; tdnei RA,ppc64::fulltag-misc; RA != nargs type check; |
---|
876 | ;; look for "clrldi rs-node,ra-imm,60" = "rldicl |
---|
877 | ;; rs,ra,60" |
---|
878 | ((and (match-instr the-trap |
---|
879 | (ppc-instruction-mask :opcode :to :d) |
---|
880 | (ppc-lap-word (tdnei ?? ppc64::fulltag-misc))) |
---|
881 | (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) |
---|
882 | (ppc-lap-word (rldicl ?? ?? 0 60)) |
---|
883 | fn pc-index)) |
---|
884 | |
---|
885 | (lisp-reg-p (setq rs (RS-field instr)))) |
---|
886 | (%error (make-condition 'type-error |
---|
887 | :datum (xp-GPR-lisp xp rs) |
---|
888 | :expected-type 'uvector) |
---|
889 | nil |
---|
890 | frame-ptr)) |
---|
891 | ;; tdlgti RA,N; RA = nargs (xy = 01) |
---|
892 | ;; tdllti RA,N; RA = nargs (xy = 10) |
---|
893 | ;; nargs check, optional or rest involved |
---|
894 | ((and (match-instr the-trap |
---|
895 | (ppc-instruction-mask :opcode (:to #x1c) :ra) |
---|
896 | (ppc-lap-word (tdi ?? ppc::nargs ??))) |
---|
897 | (or (eql #b01 (setq temp (ldb #.(ppc-instruction-field :to) the-trap))) |
---|
898 | (eql #b10 temp))) |
---|
899 | (%error (if (eql temp #b10) |
---|
900 | 'too-few-arguments |
---|
901 | 'too-many-arguments) |
---|
902 | (list :nargs (ash (xp-GPR-signed-doubleword xp ppc::nargs) |
---|
903 | (- ppc64::fixnumshift)) |
---|
904 | :fn fn) |
---|
905 | frame-ptr)) |
---|
906 | |
---|
907 | ;; tdeqi RA,N; N = unbound |
---|
908 | ;; symeval boundp check; look for "ld RA,symbol.vcell(nodereg)" |
---|
909 | ((and (match-instr the-trap |
---|
910 | (ppc-instruction-mask :opcode :to :d) |
---|
911 | (ppc-lap-word (tdeqi ?? ppc64::unbound-marker))) |
---|
912 | (setq instr (scan-for-instr (ppc-instruction-mask :opcode :ds :ds-xo) |
---|
913 | (ppc-lap-word (ld ?? ppc64::symbol.vcell ??)) |
---|
914 | fn pc-index)) |
---|
915 | (lisp-reg-p (setq ra (RA-field instr)))) |
---|
916 | (setf (xp-GPR-lisp xp (RA-field the-trap)) |
---|
917 | (%kernel-restart-internal $xvunbnd (list (xp-GPR-lisp xp ra)) frame-ptr))) |
---|
918 | ;; tdeqi RA,N: n = (%slot-unbound-marker) |
---|
919 | ;; slot-unbound trap. Look for preceding "ldx RA,rx,ry". |
---|
920 | ;; rx = slots-vector, ry = scaled index in slots vector. |
---|
921 | ((and (match-instr the-trap |
---|
922 | (ppc-instruction-mask :opcode :to :d) |
---|
923 | (ppc-lap-word (tdeqi ?? ppc64::slot-unbound-marker))) |
---|
924 | (setq instr (scan-for-instr (ppc-instruction-mask |
---|
925 | :opcode :rt :x-minor) |
---|
926 | (dpb |
---|
927 | (RA-field the-trap) |
---|
928 | (byte 5 21) |
---|
929 | (ppc-lap-word |
---|
930 | (ldx ?? ?? ??))) |
---|
931 | fn pc-index))) |
---|
932 | (setq *error-reentry-count* 0) ; succesfully reported error |
---|
933 | ;; %SLOT-UNBOUND-TRAP will decode the arguments further, |
---|
934 | ;; then call the generic function SLOT-UNBOUND. That |
---|
935 | ;; might return a value; if so, set the value of the |
---|
936 | ;; register that caused the trap to that value. |
---|
937 | (setf (xp-gpr-lisp xp (ra-field the-trap)) |
---|
938 | (%slot-unbound-trap (xp-gpr-lisp xp (RA-field instr)) |
---|
939 | (ash (- (xp-gpr-signed-doubleword xp (RB-field instr)) |
---|
940 | ppc64::misc-data-offset) |
---|
941 | (- ppc64::word-shift)) |
---|
942 | frame-ptr))) |
---|
943 | ;; tdlge RA,RB |
---|
944 | ;; vector bounds check; look for "ld immreg, misc_header_offset(nodereg)" |
---|
945 | ((and (match-instr the-trap |
---|
946 | (ppc-instruction-mask :opcode :to :x-minor) |
---|
947 | (ppc-lap-word (tdlge ?? ??))) |
---|
948 | (setq instr (scan-for-instr (ppc-instruction-mask :opcode #|:d|# :ds-xo) |
---|
949 | (ppc-lap-word (ld ?? ?? #|ppc32::misc-header-offset|# ??)) |
---|
950 | fn pc-index)) |
---|
951 | (lisp-reg-p (setq ra (RA-field instr)))) |
---|
952 | (%error (%rsc-string $xarroob) |
---|
953 | (list (xp-GPR-lisp xp (RA-field the-trap)) |
---|
954 | (xp-GPR-lisp xp ra)) |
---|
955 | frame-ptr)) |
---|
956 | ;; tdi 27 ra d - array header rank check |
---|
957 | ((and (match-instr the-trap |
---|
958 | (ppc-instruction-mask :opcode :to) |
---|
959 | (ppc-lap-word (tdi 27 ?? ??))) |
---|
960 | (setq instr (scan-for-instr (ppc-instruction-mask :opcode :ds :ds-xo) |
---|
961 | (ppc-lap-word (ld ?? ppc64::arrayH.rank ??)) |
---|
962 | fn pc-index)) |
---|
963 | (lisp-reg-p (setq ra (RA-field instr)))) |
---|
964 | (%error (%rsc-string $xndims) |
---|
965 | (list (xp-gpr-lisp xp ra) |
---|
966 | (ash (ldb (byte 16 0) the-trap) (- ppc64::fixnumshift))) |
---|
967 | frame-ptr)) |
---|
968 | ;; td 27 ra rb - array flags check |
---|
969 | ((and (match-instr the-trap |
---|
970 | (ppc-instruction-mask :opcode :to :x-minor) |
---|
971 | (ppc-lap-word (td 27 ?? ??))) |
---|
972 | (setq instr (scan-for-instr (ppc-instruction-mask :opcode :ds :ds-xo) |
---|
973 | (ppc-lap-word (ld ?? ppc64::arrayH.flags ??)) |
---|
974 | fn pc-index)) |
---|
975 | (lisp-reg-p (setq ra (RA-field instr))) |
---|
976 | (let* ((expected (xp-gpr-lisp xp (RB-field the-trap))) |
---|
977 | (expected-subtype (ldb |
---|
978 | ppc64::arrayH.flags-cell-subtag-byte |
---|
979 | expected)) |
---|
980 | (expect-simple (= |
---|
981 | (ldb ppc64::arrayH.flags-cell-bits-byte |
---|
982 | expected) |
---|
983 | (ash 1 $arh_simple_bit))) |
---|
984 | (type-name |
---|
985 | (case expected-subtype |
---|
986 | (#.ppc64::subtag-double-float-vector 'double-float)))) |
---|
987 | |
---|
988 | (and type-name expect-simple |
---|
989 | (setq condition |
---|
990 | (make-condition 'type-error |
---|
991 | :datum (xp-gpr-lisp xp ra) |
---|
992 | :expected-type |
---|
993 | `(simple-array ,type-name)))))) |
---|
994 | (%error condition nil frame-ptr)) |
---|
995 | |
---|
996 | ;; Unknown trap |
---|
997 | (t (%error "Unknown trap: #x~x~%xp: ~s, fn: ~s, pc: #x~x" |
---|
998 | (list the-trap xp fn (ash pc-index ppc64::fixnumshift)) |
---|
999 | frame-ptr))))))))) |
---|
1000 | |
---|
1001 | |
---|
1002 | |
---|
1003 | |
---|
1004 | |
---|