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

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

More files from last commit.

arm-callback-support.lisp, arm-error-signal.lisp,
arm-trap-support.lisp,l1-boot-3.lisp: try to get basic stuff working
well enough to enable callbacks. Enable callbacks.

arm-backtrace.lisp: a little bit of platform-specific code and some
code from the PPC port, so that backtrace sort of works.

File size: 11.4 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  ;; We'll clearly need some sort of xcf/fake-stack-frame -like mechanism.
124  (let* ((frame-ptr (%get-frame-ptr))
125         (fn (unless (eql fnreg 0) (xp-gpr-lisp xp fnreg))))
126    (with-error-reentry-detection
127        (cond
128          ((eql 0 error-number)         ; Hopefully a UUO.
129           (if (/= (logand arg #x0ff000f0) #x07f000f0)
130             (%error "Unknown non-UUO: #x~x" (list arg) frame-ptr)
131             (let* ((condition (ldb (byte 4 28) arg))
132                    (uuo (ldb (byte 28 0) arg))
133                    (format (ldb (byte 4 0) uuo)))
134               (declare (fixnum condition uuo format))
135               (case format
136                 ((2 10)                ; uuo-format-[c]error-lisptag
137                  (%error (make-condition
138                           'type-error
139                           :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
140                           :expected-type
141                           (svref #(fixnum list uvector immediate)
142                                  (ldb (byte 2 12) uuo)))
143                          nil
144                          frame-ptr))
145                 ((3 11)
146                  (%error (make-condition
147                           'type-error
148                           :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
149                           :expected-type
150                           (svref #(fixnum cons bogus immediate fixnum null uvector bogus)
151                                  (ldb (byte 3 12) uuo)))
152                          nil
153                          frame-ptr))
154                 ((4 12)
155                  (%error (make-condition
156                           'type-error
157                           :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
158                           :expected-type
159                           (svref *arm-xtype-specifiers* (ldb (byte 8 12) uuo)))
160                          nil
161                          frame-ptr))
162                 (8                     ;nullary error.  Only one, atm.
163                  (case (ldb (byte 12 8) uuo)
164                    (1                  ;why 1?
165                     (let* ((condition-name
166                             (cond ((eq condition arm::arm-cond-lo)
167                                    'too-few-arguments)
168                                   ((eq condition arm::arm-cond-hs)
169                                    'too-many-arguments)
170                                   (t
171                                    ;;(assert condition arm::arm-cond-ne)
172                                    (let* ((cpsr (xp-gpr-signed-long xp
173                                                                     xp-cpsr-regno)))
174                                      (if (logbitp 29 cpsr)
175                                        'too-many-arguments
176                                        'too-few-arguments))))))
177                       (%error condition-name
178                               (list :nargs (xp-gpr-lisp xp arm::nargs)
179                                     :fn fn)
180                               frame-ptr)))
181                    (t
182                     (%error "Unknown nullary UUO code ~d"
183                             (list (ldb (byte 12 8) uuo))
184                             frame-ptr))))
185                 (9                     ;unary error
186                  (let* ((code (ldb (byte 8 12) uuo))
187                         (regno (ldb (byte 4 8) uuo))
188                         (arg (xp-gpr-lisp xp regno)))
189                    (case code
190                      ((0 1)
191                       (setf (xp-gpr-lisp xp regno)
192                             (%kernel-restart-internal $xvunbnd
193                                                       (list arg)
194                                                       frame-ptr)))
195                      (2
196                       (%error (make-condition 'type-error
197                                               :datum arg
198                                               :expected-type '(or symbol function)
199                                               :format-control
200                                               "~S is not of type ~S, and can't be FUNCALLed or APPLYed")
201                               nil frame-ptr))
202                      (4
203                       (%error (make-condition 'cant-throw-error
204                                               :tag arg)
205                               nil frame-ptr))
206                      (5
207                       (handle-udf-call xp frame-ptr))
208                      (6
209                       (%err-disp-internal $xfunbnd (list arg) frame-ptr))
210                      (t
211                       (error "Unknown unary UUO with code ~d." code)))))
212                 (14
213                  (let* ((reg-a (ldb (byte 4 8) uuo))
214                         (arg-b (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
215                         (arg-c (xp-gpr-lisp xp (ldb (byte 4 16) uuo))))
216                    (setf (xp-gpr-lisp xp reg-a)
217                          (%slot-unbound-trap arg-b arg-c frame-ptr))))
218                 (15
219                  (let* ((reg-a (ldb (byte 4 8) uuo))
220                         (arga (xp-gpr-lisp xp reg-a))
221                         (argb (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
222                         (code (ldb (byte 4 16) uuo)))
223                    (case code
224                      ((0 1)            ;do we report these the same way?
225                       (%error (%rsc-string $xarroob)
226                               (list arga argb)
227                               frame-ptr))
228                      (4
229                       (let* ((eep-or-fv (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
230                              (dest-reg (ldb (byte 4 8) uuo)))
231                         (etypecase eep-or-fv
232                           (external-entry-point
233                            (resolve-eep eep-or-fv)
234                            (setf (xp-gpr-lisp xp dest-reg)
235                                  (eep.address eep-or-fv)))
236                           (foreign-variable
237                            (resolve-foreign-variable eep-or-fv)
238                            (setf (xp-gpr-lisp xp dest-reg)
239                                  (fv.addr eep-or-fv))))))
240                      (t
241                       (error "Unknown code in binary UUO: ~d" code)))))
242                 (t
243                  (error "Unknown UUO, format ~d" format))))))
244          (t
245           (error "%errdisp callback: error-number = ~d, arg = #x~x, fnreg = ~d, rpc = ~d"
246                  error-number arg fnreg relative-pc))))))
Note: See TracBrowser for help on using the repository browser.