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

Last change on this file since 14841 was 13067, checked in by rme, 10 years ago

Update copyright notices.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 22.3 KB
Line 
1;;; x86-trap-support
2;;;
3;;;   Copyright (C) 2005-2009 Clozure Associates and contributors
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
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 #x90)
105                   (setq skip (%check-anchored-uuo xcf 3))
106                   (setf (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
107                         (%kernel-restart-internal $xvunbnd
108                                                   (list
109                                                    (encoded-gpr-lisp
110                                                     xp
111                                                     (ldb (byte 4 0) op2)))
112                                                   frame-ptr)))
113                  ((< op1 #xa0)
114                   (setq skip (%check-anchored-uuo xcf 2))
115                   ;; #x9x, x>0 - register X is a symbol.  It's unbound,
116                   ;; but we don't have enough info to offer USE-VALUE,
117                   ;; STORE-VALUE, or CONTINUE restarts.
118                   (%error (make-condition 'unbound-variable
119                                           :name
120                                           (encoded-gpr-lisp
121                                               xp
122                                               (ldb (byte 4 0) op1)))
123                           ()
124                           frame-ptr))
125                  ((< op1 #xb0)
126                   (setq skip (%check-anchored-uuo xcf 2))
127                   (%err-disp-internal $xfunbnd
128                                       (list (encoded-gpr-lisp
129                                              xp
130                                              (ldb (byte 4 0) op1)))
131                                       frame-ptr))
132                  ((< op1 #xc0)
133                   (setq skip (%check-anchored-uuo xcf 3))
134                   (%err-disp-internal 
135                    #.(car (rassoc 'type-error *kernel-simple-error-classes*))
136                    (list (encoded-gpr-lisp
137                           xp
138                           (ldb (byte 4 0) op1))
139                          (logandc2 op2 arch::error-type-error))
140                    frame-ptr))
141                  ((= op1 #xc0)
142                   (setq skip (%check-anchored-uuo xcf 2))
143                   (%error 'too-few-arguments
144                           (list :nargs (xp-argument-count xp)
145                                 :fn fn)
146                           frame-ptr))
147                  ((= op1 #xc1)
148                   (setq skip (%check-anchored-uuo xcf 2))
149                   (%error 'too-many-arguments
150                           (list :nargs (xp-argument-count xp)
151                                 :fn fn)
152                           frame-ptr))
153                  ((= op1 #xc2)
154                   (setq skip (%check-anchored-uuo xcf 2))
155                   (let* ((flags (xp-flags-register xp))
156                          (nargs (xp-argument-count xp))
157                          (carry-bit (logbitp x86::x86-carry-flag-bit flags)))
158                     (if carry-bit
159                       (%error 'too-few-arguments
160                               (list :nargs nargs
161                                     :fn fn)
162                               frame-ptr)
163                       (%error 'too-many-arguments
164                               (list :nargs nargs
165                                     :fn fn)
166                               frame-ptr))))
167                  ((= op1 #xc3)         ;array rank
168                   (setq skip (%check-anchored-uuo xcf 3))                   
169                   (%err-disp-internal $XNDIMS
170                                       (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
171                                             (encoded-gpr-lisp xp (ldb (byte 4 0) op2)))
172                                       frame-ptr))
173                  ((= op1 #xc6)
174                   (setq skip (%check-anchored-uuo xcf 2))
175                   (%error (make-condition 'type-error
176                                           :datum (encoded-gpr-lisp xp x8664::temp0)
177                                           :expected-type '(or symbol function)
178                                           :format-control
179                                           "~S is not of type ~S, and can't be FUNCALLed or APPLYed")
180                           nil frame-ptr))
181                  ((= op1 #xc7)
182                   (handle-udf-call xp frame-ptr)
183                   (setq skip 0))
184                  ((or (= op1 #xc8) (= op1 #xcb))
185                   (setq skip (%check-anchored-uuo xcf 3))
186                   (%error (%rsc-string $xarroob)
187                           (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
188                                 (encoded-gpr-lisp xp (ldb (byte 4 0) op2)))
189                           frame-ptr))
190                  ((= op1 #xc9)
191                   (setq skip (%check-anchored-uuo xcf 2))
192                   (%err-disp-internal $xnotfun
193                                       (list (encoded-gpr-lisp xp x8664::temp0))
194                                       frame-ptr))
195                  ;; #xca = uuo-error-debug-trap
196                  ((= op1 #xcc)
197                   ;; external entry point or foreign variable
198                   (setq skip (%check-anchored-uuo xcf 3))
199                   (let* ((eep-or-fv (encoded-gpr-lisp xp (ldb (byte 4 4) op2))))
200                     (etypecase eep-or-fv
201                       (external-entry-point
202                        (resolve-eep eep-or-fv)
203                        (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
204                              (eep.address eep-or-fv)))
205                       (foreign-variable
206                        (resolve-foreign-variable eep-or-fv)
207                        (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
208                              (fv.addr eep-or-fv))))))
209                  ((< op1 #xe0)
210                   (setq skip (%check-anchored-uuo xcf 3))
211                   (if (= op2 x8664::subtag-catch-frame)
212                     (%error (make-condition 'cant-throw-error
213                                             :tag (encoded-gpr-lisp
214                                                   xp
215                                                   (ldb (byte 4 0) op1)))
216                             nil frame-ptr)
217                     (let* ((typename
218                             (cond ((= op2 x8664::tag-fixnum) 'fixnum)
219                                   ((= op2 x8664::tag-single-float) 'single-float)
220                                   ((= op2 x8664::subtag-character) 'character)
221                                   ((= op2 x8664::fulltag-cons) 'cons)
222                                   ((= op2 x8664::tag-misc) 'uvector)
223                                   ((= op2 x8664::fulltag-symbol) 'symbol)
224                                   ((= op2 x8664::fulltag-function) 'function)
225                                   (t (let* ((class (logand op2 x8664::fulltagmask))
226                                             (high4 (ash op2 (- x8664::ntagbits))))
227                                        (cond ((= class x8664::fulltag-nodeheader-0)
228                                               (svref *nodeheader-0-types* high4))
229                                              ((= class x8664::fulltag-nodeheader-1)
230                                               (svref *nodeheader-1-types* high4))
231                                              ((= class x8664::fulltag-immheader-0)
232                                               (svref *immheader-0-types* high4))
233                                              ((= class x8664::fulltag-immheader-1)
234                                               (svref *immheader-1-types* high4))
235                                              ((= class x8664::fulltag-immheader-2)
236                                               (svref *immheader-2-types* high4))
237                                              (t (list 'bogus op2))))))))
238                       (%error (make-condition 'type-error
239                                               :datum (encoded-gpr-lisp
240                                                       xp
241                                                       (ldb (byte 4 0) op1))
242                                               :expected-type typename)
243                               nil
244                               frame-ptr))))
245                  ((< op1 #xf0)
246                   (setq skip (%check-anchored-uuo xcf 2))
247                   (%error (make-condition 'type-error
248                                           :datum (encoded-gpr-lisp
249                                                   xp
250                                                   (ldb (byte 4 0) op1))
251                                           :expected-type 'list)
252                           nil
253                           frame-ptr))
254                  (t
255                   (setq skip (%check-anchored-uuo xcf 2))
256                   (%error (make-condition 'type-error
257                                           :datum (encoded-gpr-lisp
258                                                   xp
259                                                   (ldb (byte 4 0) op1))
260                                           :expected-type 'fixnum)
261                           nil
262                           frame-ptr)))
263            (%error "Unknown trap: #x~x~%xp=~s"
264                    (list (list op0 op1 op2) xp)
265                    frame-ptr))
266          skip))))
267
268;;; lots of duplicated code here
269#+x8632-target
270(defcallback %xerr-disp (:address xp :address xcf :int)
271  (with-error-reentry-detection
272      (let* ((frame-ptr (macptr->fixnum xcf))
273             (fn (%get-object xcf x8632::xcf.nominal-function))
274             (op0 (%get-xcf-byte xcf 0))
275             (op1 (%get-xcf-byte xcf 1))
276             (op2 (%get-xcf-byte xcf 2)))
277        (declare (type (unsigned-byte 8) op0 op1 op2))
278        (let* ((skip 2))
279          (if (and (= op0 #xcd)
280                   (>= op1 #x70))
281            (cond ((< op1 #x90)
282                   (setq skip (%check-anchored-uuo xcf 3))
283                   (setq *error-reentry-count* 0)
284                   (setf (encoded-gpr-lisp xp (ldb (byte 3 0) op1))
285                         (%slot-unbound-trap
286                          (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
287                          (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
288                          frame-ptr)))
289                  ((= op1 #x90)
290                   (setq skip (%check-anchored-uuo xcf 3))
291                   (setf (encoded-gpr-lisp
292                          xp
293                          (ldb (byte 3 0) op2))
294                         (%kernel-restart-internal $xvunbnd
295                                                   (list
296                                                    (encoded-gpr-lisp
297                                                     xp
298                                                     (ldb (byte 3 0) op2)))
299                                                   frame-ptr)))
300                  ((< op1 #xa0)
301                   (setq skip (%check-anchored-uuo xcf 2))
302                   ;; #x9x, x>- - register X is a symbol.  It's unbound,
303                   ;; but we don't have enough info to offer USE-VALUE,
304                   ;; STORE-VALUE, or CONTINUE restart
305                   (%error (make-condition 'unbound-variable
306                                           :name
307                                           (encoded-gpr-lisp
308                                               xp
309                                               (ldb (byte 3 0) op1)))
310                           ()
311                           frame-ptr))
312                  ((< op1 #xb0)
313                   (setq skip (%check-anchored-uuo xcf 2))
314                   (%err-disp-internal $xfunbnd
315                                       (list (encoded-gpr-lisp
316                                              xp
317                                              (ldb (byte 3 0) op1)))
318                                       frame-ptr))
319                  ((< op1 #xc0)
320                   (setq skip (%check-anchored-uuo xcf 3))
321                   (%err-disp-internal 
322                    #.(car (rassoc 'type-error *kernel-simple-error-classes*))
323                    (list (encoded-gpr-lisp
324                           xp
325                           (ldb (byte 3 0) op1))
326                          (logandc2 op2 arch::error-type-error))
327                    frame-ptr))
328                  ((= op1 #xc0)
329                   (setq skip (%check-anchored-uuo xcf 2))
330                   (%error 'too-few-arguments
331                           (list :nargs (xp-argument-count xp)
332                                 :fn fn)
333                           frame-ptr))
334                  ((= op1 #xc1)
335                   (setq skip (%check-anchored-uuo xcf 2))
336                   (%error 'too-many-arguments
337                           (list :nargs (xp-argument-count xp)
338                                 :fn fn)
339                           frame-ptr))
340                  ((= op1 #xc2)
341                   (setq skip (%check-anchored-uuo xcf 2))
342                   (let* ((flags (xp-flags-register xp))
343                          (nargs (xp-argument-count xp))
344                          (carry-bit (logbitp x86::x86-carry-flag-bit flags)))
345                     (if carry-bit
346                       (%error 'too-few-arguments
347                               (list :nargs nargs
348                                     :fn fn)
349                               frame-ptr)
350                       (%error 'too-many-arguments
351                               (list :nargs nargs
352                                     :fn fn)
353                               frame-ptr))))
354                  ((= op1 #xc3)         ;array rank
355                   (setq skip (%check-anchored-uuo xcf 3))
356                   (%err-disp-internal $XNDIMS
357                                       (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
358                                             (encoded-gpr-lisp xp (ldb (byte 4 0) op2)))
359                                       frame-ptr))
360                  ((= op1 #xc6)
361                   (setq skip (%check-anchored-uuo xcf 2))
362                   (%error (make-condition 'type-error
363                                           :datum (encoded-gpr-lisp xp x8632::temp0)
364                                           :expected-type '(or symbol function)
365                                           :format-control
366                                           "~S is not of type ~S, and can't be FUNCALLed or APPLYed")
367                           nil frame-ptr))
368                  ((= op1 #xc7)
369                   (handle-udf-call xp frame-ptr)
370                   (setq skip 0))
371                  ((or (= op1 #xc8) (= op1 #xcb))
372                   (setq skip (%check-anchored-uuo xcf 3))
373                   (%error (%rsc-string $xarroob)
374                           (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
375                                 (encoded-gpr-lisp xp (ldb (byte 4 0) op2)))
376                           frame-ptr))
377                  ((= op1 #xc9)
378                   (setq skip (%check-anchored-uuo xcf 2))
379                   (%err-disp-internal $xnotfun
380                                       (list (encoded-gpr-lisp xp x8632::temp0))
381                                       frame-ptr))
382                  ;; #xca = uuo-error-debug-trap
383                  ((= op1 #xcc)
384                   ;; external entry point or foreign variable
385                   (setq skip (%check-anchored-uuo xcf 3))
386                   (let* ((eep-or-fv (encoded-gpr-lisp xp (ldb (byte 4 4) op2))))
387                     (etypecase eep-or-fv
388                       (external-entry-point
389                        (resolve-eep eep-or-fv)
390                        (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
391                              (eep.address eep-or-fv)))
392                       (foreign-variable
393                        (resolve-foreign-variable eep-or-fv)
394                        (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
395                              (fv.addr eep-or-fv))))))
396                  ((< op1 #xe0)
397                   (setq skip (%check-anchored-uuo xcf 3))
398                   (if (= op2 x8632::subtag-catch-frame)
399                     (%error (make-condition 'cant-throw-error
400                                             :tag (encoded-gpr-lisp
401                                                   xp
402                                                   (ldb (byte 3 0) op1)))
403                             nil frame-ptr)
404                     (let* ((typename
405                             (cond ((= op2 x8632::tag-fixnum) 'fixnum)
406                                   ((= op2 x8632::subtag-character) 'character)
407                                   ((= op2 x8632::fulltag-cons) 'cons)
408                                   ((= op2 x8632::tag-misc) 'uvector)
409                                   (t (let* ((class (logand op2 x8632::fulltagmask))
410                                             (high5 (ash op2 (- x8632::ntagbits))))
411                                        (cond ((= class x8632::fulltag-nodeheader)
412                                               (svref *nodeheader-types* high5))
413                                              ((= class x8632::fulltag-immheader)
414                                               (svref *immheader-types* high5))
415                                              (t (list 'bogus op2))))))))
416                       (%error (make-condition 'type-error
417                                               :datum (encoded-gpr-lisp
418                                                       xp
419                                                       (ldb (byte 3 0) op1))
420                                               :expected-type typename)
421                               nil
422                               frame-ptr))))
423                  ((< op1 #xf0)
424                   (setq skip (%check-anchored-uuo xcf 2))
425                   (%error (make-condition 'type-error
426                                           :datum (encoded-gpr-lisp
427                                                   xp
428                                                   (ldb (byte 3 0) op1))
429                                           :expected-type 'list)
430                           nil
431                           frame-ptr))
432                  (t
433                   (setq skip (%check-anchored-uuo xcf 2))
434                   (%error (make-condition 'type-error
435                                           :datum (encoded-gpr-lisp
436                                                   xp
437                                                   (ldb (byte 3 0) op1))
438                                           :expected-type 'fixnum)
439                           nil
440                           frame-ptr)))
441            (%error "Unknown trap: #x~x~%xp=~s"
442                    (list (list op0 op1 op2) xp)
443                    frame-ptr))
444          skip))))
445                 
Note: See TracBrowser for help on using the repository browser.