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

Last change on this file since 14119 was 14119, checked in by gb, 9 years ago

Changes from ARM branch. Need testing ...

File size: 14.1 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 null bogus immediate fixnum cons 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            ((eql error-number arch::error-stack-overflow)
281             (%error
282              (make-condition
283               'stack-overflow-condition 
284               :format-control "Stack overflow on ~a stack."
285               :format-arguments (list (if (eql arg arm::vsp) "value" "control")))
286              nil frame-ptr))
287            (t
288             (error "%errdisp callback: error-number = ~d, arg = #x~x, fnreg = ~d, rpc = ~d"
289                    error-number arg fnreg relative-pc)))))
290    delta))
Note: See TracBrowser for help on using the repository browser.