source: trunk/source/level-1/arm-error-signal.lisp @ 15270

Last change on this file since 15270 was 15158, checked in by gb, 8 years ago

Define another 3-register-argument UUO ('uuo_error_array_axis_bounds');
use it to report array bounds errors for multidimensional array access
(incorporating the axis/dimension in the UUO and therefore the error
message.)

File size: 15.2 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 
119(defcallback %xerr-disp (:address xp
120                                  :signed-fullword error-number
121                                  :unsigned-fullword arg
122                                  :unsigned-fullword fnreg
123                                  :unsigned-fullword relative-pc
124                                  :int)
125  (let* ((fn (unless (eql 0 fnreg) (xp-gpr-lisp xp fnreg)))
126         (delta 0))
127    (with-xp-stack-frames (xp fn frame-ptr)
128      (with-error-reentry-detection
129          (cond
130            ((eql 0 error-number)       ; Hopefully a UUO.
131             (setq delta 4)
132             (if (/= (logand arg #x0ff000f0) #x07f000f0)
133               (%error "Unknown non-UUO: #x~x" (list arg) frame-ptr)
134               (let* ((condition (ldb (byte 4 28) arg))
135                      (uuo (ldb (byte 28 0) arg))
136                      (format (ldb (byte 4 0) uuo)))
137                 (declare (fixnum condition uuo format))
138                 (case format
139                   ((2 10)              ; uuo-format-[c]error-lisptag
140                    (%error (make-condition
141                             'type-error
142                             :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
143                             :expected-type
144                             (svref #(fixnum list uvector immediate)
145                                    (ldb (byte 2 12) uuo)))
146                            nil
147                            frame-ptr))
148                   ((3 11)
149                    (%error (make-condition
150                             'type-error
151                             :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
152                             :expected-type
153                             (svref #(fixnum null bogus immediate fixnum cons uvector bogus)
154                                    (ldb (byte 3 12) uuo)))
155                            nil
156                            frame-ptr))
157                   ((4 12)
158                    (%error (make-condition
159                             'type-error
160                             :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
161                             :expected-type
162                             (svref *arm-xtype-specifiers* (ldb (byte 8 12) uuo)))
163                            nil
164                            frame-ptr))
165                   (8                   ;nullary error.  Only one, atm.
166                    (case (ldb (byte 12 8) uuo)
167                      (1                ;why 1?
168                       (let* ((condition-name
169                               (cond ((eq condition arm::arm-cond-lo)
170                                      'too-few-arguments)
171                                     ((eq condition arm::arm-cond-hs)
172                                      'too-many-arguments)
173                                     (t
174                                      ;;(assert condition arm::arm-cond-ne)
175                                      (let* ((cpsr (xp-gpr-signed-long xp
176                                                                       xp-cpsr-regno)))
177                                        (if (logbitp 29 cpsr)
178                                          'too-many-arguments
179                                          'too-few-arguments))))))
180                         (%error condition-name
181                                 (list :nargs (xp-gpr-lisp xp arm::nargs)
182                                       :fn fn)
183                                 frame-ptr)))
184                      (t
185                       (%error "Unknown nullary UUO code ~d"
186                               (list (ldb (byte 12 8) uuo))
187                               frame-ptr))))
188                   (9                   ;unary error
189                    (let* ((code (ldb (byte 8 12) uuo))
190                           (regno (ldb (byte 4 8) uuo))
191                           (arg (xp-gpr-lisp xp regno)))
192                      (case code
193                        ((0 1)
194                         (setf (xp-gpr-lisp xp regno)
195                               (%kernel-restart-internal $xvunbnd
196                                                         (list arg)
197                                                         frame-ptr)))
198                        (2
199                         (%error (make-condition 'type-error
200                                                 :datum arg
201                                                 :expected-type '(or symbol function)
202                                                 :format-control
203                                                 "~S is not of type ~S, and can't be FUNCALLed or APPLYed")
204                                 nil frame-ptr))
205                        (4
206                         (%error (make-condition 'cant-throw-error
207                                                 :tag arg)
208                                 nil frame-ptr))
209                        (5
210                         (setq delta 0)
211                         (handle-udf-call xp frame-ptr))
212                        (6
213                         (%err-disp-internal $xfunbnd (list arg) frame-ptr))
214                        (t
215                         (error "Unknown unary UUO with code ~d." code)))))
216                   (14
217                    (let* ((reg-a (ldb (byte 4 8) uuo))
218                           (arg-b (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
219                           (arg-c (xp-gpr-lisp xp (ldb (byte 4 16) uuo))))
220                      (setq *error-reentry-count* 0)
221                      (setf (xp-gpr-lisp xp reg-a)
222                            (%slot-unbound-trap arg-b arg-c frame-ptr))))
223                   (15
224                    (let* ((reg-a (ldb (byte 4 8) uuo))
225                           (arga (xp-gpr-lisp xp reg-a))
226                           (argb (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
227                           (code (ldb (byte 4 16) uuo)))
228                      (case code
229                        ((0 1)          ;do we report these the same way?
230                         (%error (%rsc-string $xarroob)
231                                 (list arga argb)
232                                 frame-ptr))
233                        (4
234                         (let* ((eep-or-fv (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
235                                (dest-reg (ldb (byte 4 8) uuo)))
236                           (etypecase eep-or-fv
237                             (external-entry-point
238                              (resolve-eep eep-or-fv)
239                              (setf (xp-gpr-lisp xp dest-reg)
240                                    (eep.address eep-or-fv)))
241                             (foreign-variable
242                              (resolve-foreign-variable eep-or-fv)
243                              (setf (xp-gpr-lisp xp dest-reg)
244                                    (fv.addr eep-or-fv))))))
245                        (5              ;fpu
246                         (let* ((reginfo (xp-gpr-lisp xp (ldb (byte 4 8) uuo)))
247                                (instruction (logand (xp-gpr-signed-long xp (ldb (byte 4 12) uuo)) (1- (ash 1 32))))
248                                (condition-name (fp-condition-name-from-fpscr-status (aref reginfo 0))))
249                           (if condition-name
250                             (let* ((template (find-arm-instruction-template instruction))
251                                    (operation (if template (arithmetic-error-operation-from-instruction template) 'unknown))
252                                    (operands (if template (arithmetic-error-operands-from-instruction template instruction reginfo xp))))
253                               (%error condition-name `(:operation ,operation :operands ,operands) frame-ptr))
254                             (%error "FPU exception, fpscr = ~d" (list (aref reginfo 0)) frame-ptr)))
255                         )
256                        (6              ;array rank
257                         (%err-disp-internal $XNDIMS
258                                             (list
259                                              argb
260                                              arga)
261                                             frame-ptr))
262                        (7              ;array flags
263                         ;; This is currently only used to signal that
264                         ;; a (purported) array header doesn't have the
265                         ;; flags which denote a simple-array with
266                         ;; a particular subtype.  Decode things, then
267                         ;; signal a TYPE-ERROR.
268                         (let* ((array (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
269                                (flags (xp-gpr-lisp xp (ldb (byte 4 8) uuo)))
270                                (subtag (ldb target::arrayH.flags-cell-subtag-byte flags))
271                                (element-type
272                                 (type-specifier
273                                  (array-ctype-element-type
274                                   (specifier-type (svref *arm-xtype-specifiers* subtag))))))
275                           (%error (make-condition
276                                    'type-error
277                                    :datum array
278                                    :expected-type `(simple-array ,element-type))
279                                   nil
280                                   frame-ptr)))                       
281                        (t
282                         (error "Unknown code in binary UUO: ~d" code)))))
283                   (5
284                    (%error "Index value ~s is out of bounds for axis ~s of ~s."
285                            (list
286                             (xp-gpr-lisp xp (ldb (byte 4 16) uuo))
287                             (xp-gpr-lisp xp (ldb (byte 4 12) uuo))
288                             (xp-gpr-lisp xp (ldb (byte 4 8) uuo)))
289                            frame-ptr))
290                   (t
291                    (error "Unknown UUO, format ~d" format))))))
292            ((eql error-number arch::error-stack-overflow)
293             (%error
294              (make-condition
295               'stack-overflow-condition 
296               :format-control "Stack overflow on ~a stack."
297               :format-arguments (list (if (eql arg arm::vsp) "value" "control")))
298              nil frame-ptr))
299            ((eql error-number arch::error-allocation-disabled)
300             (restart-case (%error 'allocation-disabled nil frame-ptr)
301               (continue ()
302                         :report (lambda (stream)
303                                   (format stream "retry the heap allocation.")))))
304            (t
305             (error "%errdisp callback: error-number = ~d, arg = #x~x, fnreg = ~d, rpc = ~d"
306                    error-number arg fnreg relative-pc)))))
307    delta))
Note: See TracBrowser for help on using the repository browser.