Changeset 13922 for branches/arm/level-1/arm-error-signal.lisp
- Timestamp:
- Jul 5, 2010, 4:05:59 PM (11 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/arm/level-1/arm-error-signal.lisp
r13889 r13922 16 16 17 17 (in-package "CCL") 18 19 (defcallback %xerr-disp () 20 ) 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 TracChangeset
for help on using the changeset viewer.