Context Navigation

source: branches/arm/level-1/arm-error-signal.lisp @ 14017

Visit:

Last change on this file since 14017 was 14017, checked in by gb, 11 years ago
Handle new array UUOs. Conditionalize for ARM, provide some missing stack-walking functions.
File size: 13.8 KB

Line
1	;;;--Mode: LISP; Package: CCL --
2	;;;
3	;;; Copyright (C) 2010 Clozure Associates
4	;;; This file is part of Clozure CL.
5	;;;
6	;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7	;;; License , known as the LLGPL and distributed with Clozure CL as the
8	;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL,
9	;;; which is distributed with Clozure CL as the file "LGPL". Where these
10	;;; conflict, the preamble takes precedence.
11	;;;
12	;;; Clozure CL is referenced in the preamble as the "LIBRARY."
13	;;;
14	;;; The LLGPL is also available online at
15	;;; http://opensource.franz.com/preamble.html
16
17	(in-package "CCL")
18	(defparameter arm-xtype-specifiers (make-array 256 :initial-element nil))
19
20	(macrolet ((init-arm-xtype-table (&rest pairs)
21	(let* ((table (gensym)))
22	(collect ((body))
23	(dolist (pair pairs)
24	(destructuring-bind (code . spec) pair
25	(body `(setf (svref ,table ,code) ',spec))))
26	`(let* ((,table arm-xtype-specifiers))
27	,@(body))))))
28	(init-arm-xtype-table
29	(arm::tag-fixnum . fixnum)
30	(arm::tag-list . list)
31	(arm::xtype-integer . integer)
32	(arm::xtype-s64 . (signed-byte 64))
33	(arm::xtype-u64 . (unsigned-byte 64))
34	(arm::xtype-s32 . (signed-byte 32))
35	(arm::xtype-u32 . (unsigned-byte 32))
36	(arm::xtype-s16 . (signed-byte 16))
37	(arm::xtype-u16 . (unsigned-byte 16))
38	(arm::xtype-s8 . (signed-byte 8))
39	(arm::xtype-u8 . (unsigned-byte 8))
40	(arm::xtype-bit . bit)
41	(arm::xtype-rational . rational)
42	(arm::xtype-real . real)
43	(arm::xtype-number . number)
44	(arm::xtype-char-code . (mod #x110000))
45	(arm::xtype-unsigned-byte-24 . (unsigned-byte 24))
46	(arm::xtype-array2d . (array * (* *)))
47	(arm::xtype-array3d . (array * (* * *)))
48	(arm::subtag-bignum . bignum)
49	(arm::subtag-ratio . ratio)
50	(arm::subtag-single-float . single-float)
51	(arm::subtag-double-float . double-float)
52	(arm::subtag-complex . complex)
53	(arm::subtag-macptr . macptr)
54	(arm::subtag-code-vector . code-vector)
55	(arm::subtag-xcode-vector . xcode-vector)
56	(arm::subtag-catch-frame . catch-frame)
57	(arm::subtag-function . function)
58	(arm::subtag-basic-stream . basic-stream)
59	(arm::subtag-symbol . symbol)
60	(arm::subtag-lock . lock)
61	(arm::subtag-hash-vector . hash-vector)
62	(arm::subtag-pool . pool)
63	(arm::subtag-weak . population)
64	(arm::subtag-package . package)
65	(arm::subtag-slot-vector . slot-vector)
66	(arm::subtag-instance . standard-object)
67	(arm::subtag-struct . structure-object)
68	(arm::subtag-istruct . istruct) ;??
69	(arm::subtag-value-cell . value-cell)
70	(arm::subtag-xfunction . xfunction)
71	(arm::subtag-arrayH . array-header)
72	(arm::subtag-vectorH . vector-header)
73	(arm::subtag-simple-vector . simple-vector)
74	(arm::subtag-single-float-vector . (simple-array single-float (*)))
75	(arm::subtag-u32-vector . (simple-array (unsigned-byte 32) (*)))
76	(arm::subtag-s32-vector . (simple-array (signed-byte 32) (*)))
77	(arm::subtag-fixnum-vector . (simple-array fixnum (*)))
78	(arm::subtag-simple-base-string . simple-base-string)
79	(arm::subtag-u8-vector . (simple-array (unsigned-byte 8) (*)))
80	(arm::subtag-s8-vector . (simple-array (signed-byte 8) (*)))
81	(arm::subtag-u16-vector . (simple-array (unsigned-byte 16) (*)))
82	(arm::subtag-double-float-vector . (simple-array double-float (*)))
83	(arm::subtag-bit-vector . simple-bit-vector)))
84
85	(defun xp-argument-list (xp)
86	(let ((nargs (xp-gpr-lisp xp arm::nargs)) ; tagged as a fixnum (how convenient)
87	(arg-x (xp-gpr-lisp xp arm::arg_x))
88	(arg-y (xp-gpr-lisp xp arm::arg_y))
89	(arg-z (xp-gpr-lisp xp arm::arg_z)))
90	(cond ((eql nargs 0) nil)
91	((eql nargs 1) (list arg-z))
92	((eql nargs 2) (list arg-y arg-z))
93	(t (let ((args (list arg-x arg-y arg-z)))
94	(if (eql nargs 3)
95	args
96	(let ((vsp (xp-gpr-macptr xp arm::vsp)))
97	(dotimes (i (- nargs 3))
98	(push (%get-object vsp (* i target::node-size)) args))
99	args)))))))
100
101	(defun handle-udf-call (xp frame-ptr)
102	(let* ((args (xp-argument-list xp))
103	(values (multiple-value-list
104	(%kernel-restart-internal
105	$xudfcall
106	(list (maybe-setf-name (xp-gpr-lisp xp arm::fname)) args)
107	frame-ptr)))
108	(stack-argcnt (max 0 (- (length args) 3)))
109	(vsp (%i+ (xp-gpr-lisp xp arm::vsp) stack-argcnt))
110	(f #'(lambda (values) (apply #'values values))))
111	(setf (xp-gpr-lisp xp arm::vsp) vsp
112	(xp-gpr-lisp xp arm::nargs) 1
113	(xp-gpr-lisp xp arm::arg_z) values
114	(xp-gpr-lisp xp arm::nfn) f)
115	;; handle_uuo() (in the lisp kernel) will not bump the PC here.
116	(setf (xp-gpr-lisp xp arm::pc) (uvref f 0))))
117
118	(defcallback %xerr-disp (:address xp
119	:signed-fullword error-number
120	:unsigned-fullword arg
121	:unsigned-fullword fnreg
122	:unsigned-fullword relative-pc
123	:int)
124	(let* ((fn (unless (eql 0 fnreg) (xp-gpr-lisp xp fnreg)))
125	(delta 0))
126	(with-xp-stack-frames (xp fn frame-ptr)
127	(with-error-reentry-detection
128	(cond
129	((eql 0 error-number) ; Hopefully a UUO.
130	(setq delta 4)
131	(if (/= (logand arg #x0ff000f0) #x07f000f0)
132	(%error "Unknown non-UUO: #x~x" (list arg) frame-ptr)
133	(let* ((condition (ldb (byte 4 28) arg))
134	(uuo (ldb (byte 28 0) arg))
135	(format (ldb (byte 4 0) uuo)))
136	(declare (fixnum condition uuo format))
137	(case format
138	((2 10) ; uuo-format-[c]error-lisptag
139	(%error (make-condition
140	'type-error
141	:datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
142	:expected-type
143	(svref #(fixnum list uvector immediate)
144	(ldb (byte 2 12) uuo)))
145	nil
146	frame-ptr))
147	((3 11)
148	(%error (make-condition
149	'type-error
150	:datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
151	:expected-type
152	(svref #(fixnum cons bogus immediate fixnum null uvector bogus)
153	(ldb (byte 3 12) uuo)))
154	nil
155	frame-ptr))
156	((4 12)
157	(%error (make-condition
158	'type-error
159	:datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
160	:expected-type
161	(svref arm-xtype-specifiers (ldb (byte 8 12) uuo)))
162	nil
163	frame-ptr))
164	(8 ;nullary error. Only one, atm.
165	(case (ldb (byte 12 8) uuo)
166	(1 ;why 1?
167	(let* ((condition-name
168	(cond ((eq condition arm::arm-cond-lo)
169	'too-few-arguments)
170	((eq condition arm::arm-cond-hs)
171	'too-many-arguments)
172	(t
173	;;(assert condition arm::arm-cond-ne)
174	(let* ((cpsr (xp-gpr-signed-long xp
175	xp-cpsr-regno)))
176	(if (logbitp 29 cpsr)
177	'too-many-arguments
178	'too-few-arguments))))))
179	(%error condition-name
180	(list :nargs (xp-gpr-lisp xp arm::nargs)
181	:fn fn)
182	frame-ptr)))
183	(t
184	(%error "Unknown nullary UUO code ~d"
185	(list (ldb (byte 12 8) uuo))
186	frame-ptr))))
187	(9 ;unary error
188	(let* ((code (ldb (byte 8 12) uuo))
189	(regno (ldb (byte 4 8) uuo))
190	(arg (xp-gpr-lisp xp regno)))
191	(case code
192	((0 1)
193	(setf (xp-gpr-lisp xp regno)
194	(%kernel-restart-internal $xvunbnd
195	(list arg)
196	frame-ptr)))
197	(2
198	(%error (make-condition 'type-error
199	:datum arg
200	:expected-type '(or symbol function)
201	:format-control
202	"~S is not of type ~S, and can't be FUNCALLed or APPLYed")
203	nil frame-ptr))
204	(4
205	(%error (make-condition 'cant-throw-error
206	:tag arg)
207	nil frame-ptr))
208	(5
209	(setq delta 0)
210	(handle-udf-call xp frame-ptr))
211	(6
212	(%err-disp-internal $xfunbnd (list arg) frame-ptr))
213	(t
214	(error "Unknown unary UUO with code ~d." code)))))
215	(14
216	(let* ((reg-a (ldb (byte 4 8) uuo))
217	(arg-b (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
218	(arg-c (xp-gpr-lisp xp (ldb (byte 4 16) uuo))))
219	(setq error-reentry-count 0)
220	(setf (xp-gpr-lisp xp reg-a)
221	(%slot-unbound-trap arg-b arg-c frame-ptr))))
222	(15
223	(let* ((reg-a (ldb (byte 4 8) uuo))
224	(arga (xp-gpr-lisp xp reg-a))
225	(argb (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
226	(code (ldb (byte 4 16) uuo)))
227	(case code
228	((0 1) ;do we report these the same way?
229	(%error (%rsc-string $xarroob)
230	(list arga argb)
231	frame-ptr))
232	(4
233	(let* ((eep-or-fv (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
234	(dest-reg (ldb (byte 4 8) uuo)))
235	(etypecase eep-or-fv
236	(external-entry-point
237	(resolve-eep eep-or-fv)
238	(setf (xp-gpr-lisp xp dest-reg)
239	(eep.address eep-or-fv)))
240	(foreign-variable
241	(resolve-foreign-variable eep-or-fv)
242	(setf (xp-gpr-lisp xp dest-reg)
243	(fv.addr eep-or-fv))))))
244	(5 ;fpu
245	(let* ((reginfo (xp-gpr-lisp xp (ldb (byte 4 8) uuo)))
246	(condition-name (fp-condition-name-from-fpscr-status (aref reginfo 0))))
247	(if condition-name
248	(%error condition-name nil frame-ptr)
249	(%error "FPU exception, fpscr = ~d" (list (aref reginfo 0)) frame-ptr)))
250	)
251	(6 ;array rank
252	(%err-disp-internal $XNDIMS
253	(list
254	argb
255	arga)
256	frame-ptr))
257	(7 ;array flags
258	;; This is currently only used to signal that
259	;; a (purported) array header doesn't have the
260	;; flags which denote a simple-array with
261	;; a particular subtype. Decode things, then
262	;; signal a TYPE-ERROR.
263	(let* ((array (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
264	(flags (xp-gpr-lisp xp (ldb (byte 4 8) uuo)))
265	(subtag (ldb target::arrayH.flags-cell-subtag-byte flags))
266	(element-type
267	(type-specifier
268	(array-ctype-element-type
269	(specifier-type (svref arm-xtype-specifiers subtag))))))
270	(%error (make-condition
271	'type-error
272	:datum array
273	:expected-type `(simple-array ,element-type))
274	nil
275	frame-ptr)))
276	(t
277	(error "Unknown code in binary UUO: ~d" code)))))
278	(t
279	(error "Unknown UUO, format ~d" format))))))
280	(t
281	(error "%errdisp callback: error-number = ~d, arg = #x~x, fnreg = ~d, rpc = ~d"
282	error-number arg fnreg relative-pc)))))
283	delta))

Note: See TracBrowser for help on using the repository browser.

Download in other formats: