source: branches/working-0711/ccl/level-1/x86-error-signal.lisp @ 11832

Last change on this file since 11832 was 11771, checked in by gz, 11 years ago

r11715 from trunk

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