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

Last change on this file since 14841 was 14807, checked in by gb, 8 years ago

Define and export the functions ALLOW-HEAP-ALLOCATION and
HEAP-ALLOCATION-ALLOWED-P and the condition type ALLOCATION-DISABLED.

(ALLOW-HEAP-ALLOCATION arg) : when ARG is NIL, causes any subsequent
attempts to heap-allocate lisp memory to signal (as if by CERROR)
an ALLOCATION-DISABLED condition. (Allocaton is enabled globally at
the point where the error is signaled.) Continuing from the CERROR
restarts the allocation attempt.

This is intended to help verify that code that's not expected to
cons doesn't do so.

(This is only implemented on the ARM at the moment, but the intent
is that it be supported on all platforms.)

Note that calling (ALLOW-HEAP-ALLOCATION NIL) in the REPL CERRORs
immediately, since the REPL will cons to create the new value of CL:/.

File size: 14.4 KB
RevLine 
[14119]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))
[14807]287            ((eql error-number arch::error-allocation-disabled)
288             (restart-case (%error 'allocation-disabled nil frame-ptr)
289               (continue ()
290                         :report (lambda (stream)
291                                   (format stream "retry the heap allocation.")))))
[14119]292            (t
293             (error "%errdisp callback: error-number = ~d, arg = #x~x, fnreg = ~d, rpc = ~d"
294                    error-number arg fnreg relative-pc)))))
295    delta))
Note: See TracBrowser for help on using the repository browser.