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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

File size: 17.1 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;; Copyright 2010 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
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   (arm::subtag-complex-single-float-vector . (simple-array (complex single-float) (*)))
85   (arm::subtag-complex-double-float-vector . (simple-array (complex double-float) (*)))))
86 
87
88;;; Return a pointer to the saved VFP info a ucontext's mcontext,
89;;; and the FPSCR values in that info as an unsigned 32-bit integer.
90;;; Return a null pointer an 0 if this info can't be found.
91(defun xp-vfp-info (xp)
92  (let* ((p (pref xp :ucontext.uc_regspace)))
93    (loop
94      (let* ((magic (%get-unsigned-long p)))
95        (case magic
96          (#x56465001                    ;VFP magic
97           (%incf-ptr p 8)
98           (return (values p (%get-unsigned-long p (* 32 8)))))
99          ((#x12ef842a #x5065cf03)      ;IWMMXT or CRUNCH magic
100           (%incf-ptr p (%get-unsigned-long p 4)))
101          (otherwise
102           (return (values #-cross-compiling +null-ptr+ #+cross-compiling (%null-ptr)  0))))))))
103
104(defun xp-argument-list (xp)
105  (let ((nargs (xp-gpr-lisp xp arm::nargs))     ; tagged as a fixnum (how convenient)
106        (arg-x (xp-gpr-lisp xp arm::arg_x))
107        (arg-y (xp-gpr-lisp xp arm::arg_y))
108        (arg-z (xp-gpr-lisp xp arm::arg_z)))
109    (cond ((eql nargs 0) nil)
110          ((eql nargs 1) (list arg-z))
111          ((eql nargs 2) (list arg-y arg-z))
112          (t (let ((args (list arg-x arg-y arg-z)))
113               (if (eql nargs 3)
114                 args
115                 (let ((vsp (xp-gpr-macptr xp arm::vsp)))
116                   (dotimes (i (- nargs 3))
117                     (push (%get-object vsp (* i target::node-size)) args))
118                   args)))))))
119
120(defun handle-udf-call (xp frame-ptr)
121  (let* ((args (xp-argument-list xp))
122         (values (multiple-value-list
123                  (%kernel-restart-internal
124                   $xudfcall
125                   (list (maybe-setf-name (xp-gpr-lisp xp arm::fname)) args)
126                   frame-ptr)))
127         (stack-argcnt (max 0 (- (length args) 3)))
128         (vsp (%i+ (xp-gpr-lisp xp arm::vsp) stack-argcnt))
129         (f #'(lambda (values) (apply #'values values))))
130    (setf (xp-gpr-lisp xp arm::vsp) vsp
131          (xp-gpr-lisp xp arm::nargs) 1
132          (xp-gpr-lisp xp arm::arg_z) values
133          (xp-gpr-lisp xp arm::nfn) f)
134    ;; handle_uuo() (in the lisp kernel) will not bump the PC here.
135    (setf (xp-gpr-lisp xp arm::pc) (uvref f 0))))
136
137(defun preceding-fpu-instruction (xp)
138  (let* ((f (xp-gpr-lisp xp arm::fn)))
139    (when (typep f 'function)
140      (let* ((idx
141              (loop (let* ((pc (xp-gpr-lisp xp arm::pc))
142                           (entry (%svref f 0))
143                           (d (- pc entry)))
144                      (when (and (eql pc (xp-gpr-lisp xp arm::pc))
145                                 (eql entry (%svref f 0)))
146                        (return d)))))
147             (cv (%svref f 1)))
148        (declare (fixnum idx))
149        (do* ((i (1- idx) (1- i)))
150             ((< i 0))
151          (declare (fixnum i))
152          (let* ((inst (uvref cv i))
153                 (masked (logand inst #x0f000f00)))
154            (when (and (or (eql masked #x0e000b00)
155                           (eql masked #x0e000a00))
156                       ;; Ignore fmxr, fmrx ...
157                       (not (eql #x10 (logand inst #xff))))
158              (return inst))))))))
159             
160 
161(defcallback %xerr-disp (:address xp
162                                  :signed-fullword error-number
163                                  :unsigned-fullword arg
164                                  :unsigned-fullword fnreg
165                                  :unsigned-fullword relative-pc
166                                  :int)
167  (let* ((fn (unless (eql 0 fnreg) (xp-gpr-lisp xp fnreg)))
168         (delta 0))
169    (with-xp-stack-frames (xp fn frame-ptr)
170      (with-error-reentry-detection
171          (cond
172            ((eql 0 error-number)       ; Hopefully a UUO.
173             (setq delta 4)
174             (if (/= (logand arg #x0ff000f0) #x07f000f0)
175               (%error "Unknown non-UUO: #x~x" (list arg) frame-ptr)
176               (let* ((condition (ldb (byte 4 28) arg))
177                      (uuo (ldb (byte 28 0) arg))
178                      (format (ldb (byte 4 0) uuo)))
179                 (case format
180                   ((2 10)              ; uuo-format-[c]error-lisptag
181                    (%error (make-condition
182                             'type-error
183                             :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
184                             :expected-type
185                             (svref #(fixnum list uvector immediate)
186                                    (ldb (byte 2 12) uuo)))
187                            nil
188                            frame-ptr))
189                   ((3 11)
190                    (%error (make-condition
191                             'type-error
192                             :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
193                             :expected-type
194                             (svref #(fixnum null bogus immediate fixnum cons uvector bogus)
195                                    (ldb (byte 3 12) uuo)))
196                            nil
197                            frame-ptr))
198                   ((4 12)
199                    (%error (make-condition
200                             'type-error
201                             :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
202                             :expected-type
203                             (svref *arm-xtype-specifiers* (ldb (byte 8 12) uuo)))
204                            nil
205                            frame-ptr))
206                   (8                   ;nullary error.  Only one, atm.
207                    (case (ldb (byte 12 8) uuo)
208                      (1                ;why 1?
209                       (let* ((condition-name
210                               (cond ((eq condition arm::arm-cond-lo)
211                                      'too-few-arguments)
212                                     ((eq condition arm::arm-cond-hs)
213                                      'too-many-arguments)
214                                     (t
215                                      ;;(assert condition arm::arm-cond-ne)
216                                      (let* ((cpsr (xp-gpr-signed-long xp
217                                                                       xp-cpsr-regno)))
218                                        (if (logbitp 29 cpsr)
219                                          'too-many-arguments
220                                          'too-few-arguments))))))
221                         (%error condition-name
222                                 (list :nargs (xp-gpr-lisp xp arm::nargs)
223                                       :fn fn)
224                                 frame-ptr)))
225                      (t
226                       (%error "Unknown nullary UUO code ~d"
227                               (list (ldb (byte 12 8) uuo))
228                               frame-ptr))))
229                   (9                   ;unary error
230                    (let* ((code (ldb (byte 8 12) uuo))
231                           (regno (ldb (byte 4 8) uuo))
232                           (arg (xp-gpr-lisp xp regno)))
233                      (case code
234                        ((0 1)
235                         (setf (xp-gpr-lisp xp regno)
236                               (%kernel-restart-internal $xvunbnd
237                                                         (list arg)
238                                                         frame-ptr)))
239                        (2
240                         (%error (make-condition 'type-error
241                                                 :datum arg
242                                                 :expected-type '(or symbol function)
243                                                 :format-control
244                                                 "~S is not of type ~S, and can't be FUNCALLed or APPLYed")
245                                 nil frame-ptr))
246                        (4
247                         (%error (make-condition 'cant-throw-error
248                                                 :tag arg)
249                                 nil frame-ptr))
250                        (5
251                         (setq delta 0)
252                         (handle-udf-call xp frame-ptr))
253                        (6
254                         (%err-disp-internal $xfunbnd (list arg) frame-ptr))
255                        (t
256                         (error "Unknown unary UUO with code ~d." code)))))
257                   (14
258                    (let* ((reg-a (ldb (byte 4 8) uuo))
259                           (arg-b (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
260                           (arg-c (xp-gpr-lisp xp (ldb (byte 4 16) uuo))))
261                      (setq *error-reentry-count* 0)
262                      (setf (xp-gpr-lisp xp reg-a)
263                            (%slot-unbound-trap arg-b arg-c frame-ptr))))
264                   (15
265                    (let* ((reg-a (ldb (byte 4 8) uuo))
266                           (arga (xp-gpr-lisp xp reg-a))
267                           (argb (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
268                           (code (ldb (byte 4 16) uuo)))
269                      (case code
270                        ((0 1)          ;do we report these the same way?
271                         (%error (%rsc-string $xarroob)
272                                 (list arga argb)
273                                 frame-ptr))
274                        (4
275                         (let* ((eep-or-fv (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
276                                (dest-reg (ldb (byte 4 8) uuo)))
277                           (etypecase eep-or-fv
278                             (external-entry-point
279                              (resolve-eep eep-or-fv)
280                              (setf (xp-gpr-lisp xp dest-reg)
281                                    (eep.address eep-or-fv)))
282                             (foreign-variable
283                              (resolve-foreign-variable eep-or-fv)
284                              (setf (xp-gpr-lisp xp dest-reg)
285                                    (fv.addr eep-or-fv))))))
286                        (5              ;fpu
287                         (let* ((vfp-regs (xp-vfp-info xp))
288                                (status (xp-gpr-unsigned-long xp (ldb (byte 4 8) uuo)))
289                                (instruction (preceding-fpu-instruction xp))
290                                (condition-name (fp-condition-name-from-fpscr-status status)))
291                           (if (and condition-name instruction)
292                             (let* ((template (find-arm-instruction-template instruction))
293                                    (operation (if template (arithmetic-error-operation-from-instruction template) 'unknown))
294                                    (operands (if template (arithmetic-error-operands-from-instruction template instruction vfp-regs xp))))
295                               (%error condition-name `(:operation ,operation :operands ,operands) frame-ptr))
296                             (%error "FPU exception, fpscr = ~d" (list status) frame-ptr))
297                         ))
298                        (6              ;array rank
299                         (%err-disp-internal $XNDIMS
300                                             (list
301                                              argb
302                                              arga)
303                                             frame-ptr))
304                        (7              ;array flags
305                         ;; This is currently only used to signal that
306                         ;; a (purported) array header doesn't have the
307                         ;; flags which denote a simple-array with
308                         ;; a particular subtype.  Decode things, then
309                         ;; signal a TYPE-ERROR.
310                         (let* ((array (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
311                                (flags (xp-gpr-lisp xp (ldb (byte 4 8) uuo)))
312                                (subtag (ldb target::arrayH.flags-cell-subtag-byte flags))
313                                (element-type
314                                 (type-specifier
315                                  (array-ctype-element-type
316                                   (specifier-type (svref *arm-xtype-specifiers* subtag))))))
317
318                           (%error (make-condition
319                                    'type-error
320                                    :datum array
321                                    :expected-type `(,(if (logbitp $arh_simple_bit flags) 'simple-array 'array) ,element-type))
322                                   nil
323                                   frame-ptr)))                       
324                        (t
325                         (error "Unknown code in binary UUO: ~d" code)))))
326                   (5
327                    (%error "Index value ~s is out of bounds for axis ~s of ~s."
328                            (list
329                             (xp-gpr-lisp xp (ldb (byte 4 16) uuo))
330                             (xp-gpr-lisp xp (ldb (byte 4 12) uuo))
331                             (xp-gpr-lisp xp (ldb (byte 4 8) uuo)))
332                            frame-ptr))
333                   (t
334                    (error "Unknown UUO, format ~d" format))))))
335            ((eql error-number arch::error-stack-overflow)
336             (%error
337              (make-condition
338               'stack-overflow-condition 
339               :format-control "Stack overflow on ~a stack."
340               :format-arguments (list (if (eql arg arm::vsp) "value" "control")))
341              nil frame-ptr))
342            ((eql error-number arch::error-allocation-disabled)
343             (restart-case (%error 'allocation-disabled nil frame-ptr)
344               (continue ()
345                         :report (lambda (stream)
346                                   (format stream "retry the heap allocation.")))))
347            (t
348             (error "%errdisp callback: error-number = ~d, arg = #x~x, fnreg = ~d, rpc = ~d"
349                    error-number arg fnreg relative-pc)))))
350    delta))
Note: See TracBrowser for help on using the repository browser.