source: branches/ia32/level-1/x86-error-signal.lisp @ 9384

Last change on this file since 9384 was 9384, checked in by rme, 13 years ago

%xerr-disp for x8632; probably buggy.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 18.8 KB
Line 
1;;; x86-trap-support
2;;;
3;;;   Copyright (C) 2005-2006 Clozure Associates and contributors
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL 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
18(in-package "CCL")
19
20(defun xp-argument-count (xp)
21  (ldb (byte (- 16 x8664::fixnumshift) 0)
22                    (encoded-gpr-lisp xp x8664::nargs.q)))
23
24
25
26(defun xp-argument-list (xp)
27  (let ((nargs (xp-argument-count xp))
28        (arg-x (encoded-gpr-lisp xp x8664::arg_x))
29        (arg-y (encoded-gpr-lisp xp x8664::arg_y))
30        (arg-z (encoded-gpr-lisp xp x8664::arg_z)))
31    (cond ((eql nargs 0) nil)
32          ((eql nargs 1) (list arg-z))
33          ((eql nargs 2) (list arg-y arg-z))
34          (t
35           (let ((args (list arg-x arg-y arg-z)))
36             (if (eql nargs 3)
37               args
38               (let ((sp (%inc-ptr (encoded-gpr-macptr xp x8664::rsp)
39                                   (+ x8664::node-size x8664::xcf.size))))
40                 (dotimes (i (- nargs 3))
41                   (push (%get-object sp (* i x8664::node-size)) args))
42                 args)))))))
43                         
44;;; Making this be continuable is hard, because of the xcf on the
45;;; stack and the way that the kernel saves/restores rsp and rbp
46;;; before calling out.  If we get around those problems, then
47;;; we have to also deal with the fact that the return address
48;;; is on the stack.  Easiest to make the kernel deal with that,
49;;; and just set %fn to the function that returns the values
50;;; returned by the (newly defined) function and %arg_z to
51;;; that list of values.
52(defun handle-udf-call (xp frame-ptr)
53  (let* ((args (xp-argument-list xp))
54         (values (multiple-value-list
55                  (%kernel-restart-internal
56                   $xudfcall
57                   (list (encoded-gpr-lisp xp x8664::fname) args)
58                   frame-ptr)))
59         (f #'(lambda (values) (apply #'values values))))
60    (setf (encoded-gpr-lisp xp x8664::arg_z) values
61          (encoded-gpr-lisp xp x8664::fn) f)))
62
63#+x8664-target
64(defcallback %xerr-disp (:address xp :address xcf :int)
65  (with-error-reentry-detection
66      (let* ((frame-ptr (macptr->fixnum xcf))
67             (fn (%get-object xcf x8664::xcf.nominal-function))
68             (op0 (%get-xcf-byte xcf 0))
69             (op1 (%get-xcf-byte xcf 1))
70             (op2 (%get-xcf-byte xcf 2)))
71        (declare (type (unsigned-byte 8) op0 op1 op2))
72        (let* ((skip 2))
73          (if (and (= op0 #xcd)
74                   (>= op1 #x70))
75            (cond ((< op1 #x90)
76                   (setq skip 3)
77                   (setq *error-reentry-count* 0)
78                   (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op1))
79                         (%slot-unbound-trap
80                          (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
81                          (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
82                          frame-ptr)))
83                  ((< op1 #xa0)
84                   ;; #x9x - register X is a symbol.  It's unbound.
85                   (%kernel-restart-internal $xvunbnd
86                                             (list
87                                              (encoded-gpr-lisp
88                                               xp
89                                               (ldb (byte 4 0) op1)))
90                                             frame-ptr))
91                  ((< op1 #xb0)
92                   (%err-disp-internal $xfunbnd
93                                       (list (encoded-gpr-lisp
94                                              xp
95                                              (ldb (byte 4 0) op1)))
96                                       frame-ptr))
97                  ((< op1 #xc0)
98                   (setq skip 3)
99                   (%err-disp-internal 
100                    #.(car (rassoc 'type-error *kernel-simple-error-classes*))
101                    (list (encoded-gpr-lisp
102                           xp
103                           (ldb (byte 4 0) op1))
104                          (logandc2 op2 arch::error-type-error))
105                    frame-ptr))
106                  ((= op1 #xc0)
107                   (%error 'too-few-arguments
108                           (list :nargs (xp-argument-count xp)
109                                 :fn fn)
110                           frame-ptr))
111                  ((= op1 #xc1)
112                   (%error 'too-many-arguments
113                           (list :nargs (xp-argument-count xp)
114                                 :fn fn)
115                           frame-ptr))
116                  ((= op1 #xc2)
117                   (let* ((flags (xp-flags-register xp))
118                          (nargs (xp-argument-count xp))
119                          (carry-bit (logbitp x86::x86-carry-flag-bit flags)))
120                     (if carry-bit
121                       (%error 'too-few-arguments
122                               (list :nargs nargs
123                                     :fn fn)
124                               frame-ptr)
125                       (%error 'too-many-arguments
126                               (list :nargs nargs
127                                     :fn fn)
128                               frame-ptr))))
129                  ((= op1 #xc3)         ;array rank
130                   (%err-disp-internal $XNDIMS
131                                       (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
132                                             (encoded-gpr-lisp xp (ldb (byte 4 0) op2)))
133                                       frame-ptr))
134                  ((= op1 #xc6)
135                   (%error (make-condition 'type-error
136                                           :datum (encoded-gpr-lisp xp x8664::temp0)
137                                           :expected-type '(or symbol function)
138                                           :format-control
139                                           "~S is not of type ~S, and can't be FUNCALLed or APPLYed")
140                           nil frame-ptr))
141                  ((= op1 #xc7)
142                   (handle-udf-call xp frame-ptr)
143                   (setq skip 0))
144                  ((or (= op1 #xc8) (= op1 #xcb))
145                   (setq skip 3)
146                   (%error (%rsc-string $xarroob)
147                           (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
148                                 (encoded-gpr-lisp xp (ldb (byte 4 0) op2)))
149                           frame-ptr))
150                  ((= op1 #xc9)
151                   (%err-disp-internal $xnotfun
152                                       (list (encoded-gpr-lisp xp x8664::temp0))
153                                       frame-ptr))
154                  ;; #xca = uuo-error-debug-trap
155                  ((= op1 #xcc)
156                   ;; external entry point or foreign variable
157                   (setq skip 3)
158                   (let* ((eep-or-fv (encoded-gpr-lisp xp (ldb (byte 4 4) op2))))
159                     (etypecase eep-or-fv
160                       (external-entry-point
161                        (resolve-eep eep-or-fv)
162                        (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
163                              (eep.address eep-or-fv)))
164                       (foreign-variable
165                        (resolve-foreign-variable eep-or-fv)
166                        (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
167                              (fv.addr eep-or-fv))))))
168                  ((< op1 #xe0)
169                   (setq skip 3)
170                   (if (= op2 x8664::subtag-catch-frame)
171                     (%error (make-condition 'cant-throw-error
172                                             :tag (encoded-gpr-lisp
173                                                   xp
174                                                   (ldb (byte 4 0) op1)))
175                             nil frame-ptr)
176                     (let* ((typename
177                             (cond ((= op2 x8664::tag-fixnum) 'fixnum)
178                                   ((= op2 x8664::tag-single-float) 'single-float)
179                                   ((= op2 x8664::subtag-character) 'character)
180                                   ((= op2 x8664::fulltag-cons) 'cons)
181                                   ((= op2 x8664::tag-misc) 'uvector)
182                                   ((= op2 x8664::fulltag-symbol) 'symbol)
183                                   ((= op2 x8664::fulltag-function) 'function)
184                                   (t (let* ((class (logand op2 x8664::fulltagmask))
185                                             (high4 (ash op2 (- x8664::ntagbits))))
186                                        (cond ((= class x8664::fulltag-nodeheader-0)
187                                               (svref *nodeheader-0-types* high4))
188                                              ((= class x8664::fulltag-nodeheader-1)
189                                               (svref *nodeheader-1-types* high4))
190                                              ((= class x8664::fulltag-immheader-0)
191                                               (svref *immheader-0-types* high4))
192                                              ((= class x8664::fulltag-immheader-1)
193                                               (svref *immheader-1-types* high4))
194                                              ((= class x8664::fulltag-immheader-2)
195                                               (svref *immheader-2-types* high4))
196                                              (t (list 'bogus op2))))))))
197                       (%error (make-condition 'type-error
198                                               :datum (encoded-gpr-lisp
199                                                       xp
200                                                       (ldb (byte 4 0) op1))
201                                               :expected-type typename)
202                               nil
203                               frame-ptr))))
204                  ((< op1 #xf0)
205                   (%error (make-condition 'type-error
206                                           :datum (encoded-gpr-lisp
207                                                   xp
208                                                   (ldb (byte 4 0) op1))
209                                           :expected-type 'list)
210                           nil
211                           frame-ptr))
212                  (t
213                   (%error (make-condition 'type-error
214                                           :datum (encoded-gpr-lisp
215                                                   xp
216                                                   (ldb (byte 4 0) op1))
217                                           :expected-type 'fixnum)
218                           nil
219                           frame-ptr)))
220            (%error "Unknown trap: #x~x~%xp=~s"
221                    (list (list op0 op1 op2) xp)
222                    frame-ptr))
223          skip))))
224
225;;; lots of duplicated code here
226#+x8632-target
227(defcallback %xerr-disp (:address xp :address xcf :int)
228  (with-error-reentry-detection
229      (let* ((frame-ptr (macptr->fixnum xcf))
230             (fn (%get-object xcf x8632::xcf.nominal-function))
231             (op0 (%get-xcf-byte xcf 0))
232             (op1 (%get-xcf-byte xcf 1))
233             (op2 (%get-xcf-byte xcf 2)))
234        (declare (type (unsigned-byte 8) op0 op1 op2))
235        (let* ((skip 2))
236          (if (and (= op0 #xcd)
237                   (>= op1 #x70))
238            (cond ((< op1 #x90)
239                   (setq skip 3)
240                   (setq *error-reentry-count* 0)
241                   (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op1))
242                         (%slot-unbound-trap
243                          (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
244                          (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
245                          frame-ptr)))
246                  ((< op1 #xa0)
247                   ;; #x9x - register X is a symbol.  It's unbound.
248                   (%kernel-restart-internal $xvunbnd
249                                             (list
250                                              (encoded-gpr-lisp
251                                               xp
252                                               (ldb (byte 4 0) op1)))
253                                             frame-ptr))
254                  ((< op1 #xb0)
255                   (%err-disp-internal $xfunbnd
256                                       (list (encoded-gpr-lisp
257                                              xp
258                                              (ldb (byte 4 0) op1)))
259                                       frame-ptr))
260                  ((< op1 #xc0)
261                   (setq skip 3)
262                   (%err-disp-internal 
263                    #.(car (rassoc 'type-error *kernel-simple-error-classes*))
264                    (list (encoded-gpr-lisp
265                           xp
266                           (ldb (byte 4 0) op1))
267                          (logandc2 op2 arch::error-type-error))
268                    frame-ptr))
269                  ((= op1 #xc0)
270                   (%error 'too-few-arguments
271                           (list :nargs (xp-argument-count xp)
272                                 :fn fn)
273                           frame-ptr))
274                  ((= op1 #xc1)
275                   (%error 'too-many-arguments
276                           (list :nargs (xp-argument-count xp)
277                                 :fn fn)
278                           frame-ptr))
279                  ((= op1 #xc2)
280                   (let* ((flags (xp-flags-register xp))
281                          (nargs (xp-argument-count xp))
282                          (carry-bit (logbitp x86::x86-carry-flag-bit flags)))
283                     (if carry-bit
284                       (%error 'too-few-arguments
285                               (list :nargs nargs
286                                     :fn fn)
287                               frame-ptr)
288                       (%error 'too-many-arguments
289                               (list :nargs nargs
290                                     :fn fn)
291                               frame-ptr))))
292                  ((= op1 #xc3)         ;array rank
293                   (%err-disp-internal $XNDIMS
294                                       (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
295                                             (encoded-gpr-lisp xp (ldb (byte 4 0) op2)))
296                                       frame-ptr))
297                  ((= op1 #xc6)
298                   (%error (make-condition 'type-error
299                                           :datum (encoded-gpr-lisp xp x8632::temp0)
300                                           :expected-type '(or symbol function)
301                                           :format-control
302                                           "~S is not of type ~S, and can't be FUNCALLed or APPLYed")
303                           nil frame-ptr))
304                  ((= op1 #xc7)
305                   (handle-udf-call xp frame-ptr)
306                   (setq skip 0))
307                  ((or (= op1 #xc8) (= op1 #xcb))
308                   (setq skip 3)
309                   (%error (%rsc-string $xarroob)
310                           (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
311                                 (encoded-gpr-lisp xp (ldb (byte 4 0) op2)))
312                           frame-ptr))
313                  ((= op1 #xc9)
314                   (%err-disp-internal $xnotfun
315                                       (list (encoded-gpr-lisp xp x8632::temp0))
316                                       frame-ptr))
317                  ;; #xca = uuo-error-debug-trap
318                  ((= op1 #xcc)
319                   ;; external entry point or foreign variable
320                   (setq skip 3)
321                   (let* ((eep-or-fv (encoded-gpr-lisp xp (ldb (byte 4 4) op2))))
322                     (etypecase eep-or-fv
323                       (external-entry-point
324                        (resolve-eep eep-or-fv)
325                        (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
326                              (eep.address eep-or-fv)))
327                       (foreign-variable
328                        (resolve-foreign-variable eep-or-fv)
329                        (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
330                              (fv.addr eep-or-fv))))))
331                  ((< op1 #xe0)
332                   (setq skip 3)
333                   (if (= op2 x8632::subtag-catch-frame)
334                     (%error (make-condition 'cant-throw-error
335                                             :tag (encoded-gpr-lisp
336                                                   xp
337                                                   (ldb (byte 4 0) op1)))
338                             nil frame-ptr)
339                     (let* ((typename
340                             (cond ((= op2 x8632::tag-fixnum) 'fixnum)
341                                   ((= op2 x8632::subtag-character) 'character)
342                                   ((= op2 x8632::fulltag-cons) 'cons)
343                                   ((= op2 x8632::tag-misc) 'uvector)
344                                   (t (let* ((class (logand op2 x8632::fulltagmask))
345                                             (high5 (ash op2 (- x8632::ntagbits))))
346                                        (cond ((= class x8632::fulltag-nodeheader)
347                                               (svref *nodeheader-types* high5))
348                                              ((= class x8632::fulltag-immheader)
349                                               (svref *immheader-types* high5))
350                                              (t (list 'bogus op2))))))))
351                       (%error (make-condition 'type-error
352                                               :datum (encoded-gpr-lisp
353                                                       xp
354                                                       (ldb (byte 4 0) op1))
355                                               :expected-type typename)
356                               nil
357                               frame-ptr))))
358                  ((< op1 #xf0)
359                   (%error (make-condition 'type-error
360                                           :datum (encoded-gpr-lisp
361                                                   xp
362                                                   (ldb (byte 4 0) op1))
363                                           :expected-type 'list)
364                           nil
365                           frame-ptr))
366                  (t
367                   (%error (make-condition 'type-error
368                                           :datum (encoded-gpr-lisp
369                                                   xp
370                                                   (ldb (byte 4 0) op1))
371                                           :expected-type 'fixnum)
372                           nil
373                           frame-ptr)))
374            (%error "Unknown trap: #x~x~%xp=~s"
375                    (list (list op0 op1 op2) xp)
376                    frame-ptr))
377          skip))))
378                 
Note: See TracBrowser for help on using the repository browser.