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

Last change on this file since 6558 was 6558, checked in by gb, 14 years ago

xp-argument-list: stack args are under return address, exception callback
frame (xcf) on stack.

handle-udf-call: don't try to fix up the stack if we try to continue;
let kernel deal with this after the callback.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.1 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(defcallback %xerr-disp (:address xp :address xcf :int)
64  (with-error-reentry-detection
65      (let* ((frame-ptr (macptr->fixnum xcf))
66             (fn (%get-object xcf x8664::xcf.nominal-function))
67             (op0 (%get-xcf-byte xcf 0))
68             (op1 (%get-xcf-byte xcf 1))
69             (op2 (%get-xcf-byte xcf 2)))
70        (declare (type (unsigned-byte 8) op0 op1 op2))
71        (let* ((skip 2))
72          (if (and (= op0 #xcd)
73                   (>= op1 #x70))
74            (cond ((< op1 #x90)
75                   (setq skip 3)
76                   (setq *error-reentry-count* 0)
77                   (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op1))
78                         (%slot-unbound-trap
79                          (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
80                          (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
81                          frame-ptr)))
82                  ((< op1 #xa0)
83                   ;; #x9x - register X is a symbol.  It's unbound.
84                   (%kernel-restart-internal $xvunbnd
85                                             (list
86                                              (encoded-gpr-lisp
87                                               xp
88                                               (ldb (byte 4 0) op1)))
89                                             frame-ptr))
90                  ((< op1 #xb0)
91                   (%err-disp-internal $xfunbnd
92                                       (list (encoded-gpr-lisp
93                                              xp
94                                              (ldb (byte 4 0) op1)))
95                                       frame-ptr))
96                  ((< op1 #xc0)
97                   (setq skip 3)
98                   (%err-disp-internal 
99                    #.(car (rassoc 'type-error *kernel-simple-error-classes*))
100                    (list (encoded-gpr-lisp
101                           xp
102                           (ldb (byte 4 0) op1))
103                          (logandc2 op2 arch::error-type-error))
104                    frame-ptr))
105                  ((= op1 #xc0)
106                   (%error 'too-few-arguments
107                           (list :nargs (xp-argument-count xp)
108                                 :fn fn)
109                           frame-ptr))
110                  ((= op1 #xc1)
111                   (%error 'too-many-arguments
112                           (list :nargs (xp-argument-count xp)
113                                 :fn fn)
114                           frame-ptr))
115                  ((= op1 #xc2)
116                   (let* ((flags (xp-flags-register xp))
117                          (nargs (xp-argument-count xp))
118                          (carry-bit (logbitp x86::x86-carry-flag-bit flags)))
119                     (if carry-bit
120                       (%error 'too-few-arguments
121                               (list :nargs nargs
122                                     :fn fn)
123                               frame-ptr)
124                       (%error 'too-many-arguments
125                               (list :nargs nargs
126                                     :fn fn)
127                               frame-ptr))))
128                  ((= op1 #xc3)         ;array rank
129                   (%err-disp-internal $XNDIMS
130                                       (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
131                                             (encoded-gpr-lisp xp (ldb (byte 4 0) op2)))
132                                       frame-ptr))
133                  ((= op1 #xc6)
134                   (%error (make-condition 'type-error
135                                           :datum (encoded-gpr-lisp xp x8664::temp0)
136                                           :expected-type '(or symbol function)
137                                           :format-control
138                                           "~S is not of type ~S, and can't be FUNCALLed or APPLYed")
139                           nil frame-ptr))
140                  ((= op1 #xc7)
141                   (handle-udf-call xp frame-ptr)
142                   (setq skip 0))
143                  ((or (= op1 #xc8) (= op1 #xcb))
144                   (setq skip 3)
145                   (%error (%rsc-string $xarroob)
146                           (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
147                                 (encoded-gpr-lisp xp (ldb (byte 4 0) op2)))
148                           frame-ptr))
149                  ((= op1 #xc9)
150                   (%err-disp-internal $xnotfun
151                                       (list (encoded-gpr-lisp xp x8664::temp0))
152                                       frame-ptr))
153                  ;; #xca = uuo-error-debug-trap
154                  ((= op1 #xcc)
155                   ;; external entry point or foreign variable
156                   (setq skip 3)
157                   (let* ((eep-or-fv (encoded-gpr-lisp xp (ldb (byte 4 4) op2))))
158                     (etypecase eep-or-fv
159                       (external-entry-point
160                        (resolve-eep eep-or-fv)
161                        (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
162                              (eep.address eep-or-fv)))
163                       (foreign-variable
164                        (resolve-foreign-variable eep-or-fv)
165                        (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
166                              (fv.addr eep-or-fv))))))
167                  ((< op1 #xe0)
168                   (setq skip 3)
169                   (if (= op2 x8664::subtag-catch-frame)
170                     (%error (make-condition 'cant-throw-error
171                                             :tag (encoded-gpr-lisp
172                                                   xp
173                                                   (ldb (byte 4 0) op1)))
174                             nil frame-ptr)
175                     (let* ((typename
176                             (cond ((= op2 x8664::tag-fixnum) 'fixnum)
177                                   ((= op2 x8664::tag-single-float) 'single-float)
178                                   ((= op2 x8664::subtag-character) 'character)
179                                   ((= op2 x8664::fulltag-cons) 'cons)
180                                   ((= op2 x8664::tag-misc) 'uvector)
181                                   ((= op2 x8664::fulltag-symbol) 'symbol)
182                                   ((= op2 x8664::fulltag-function) 'function)
183                                   (t (let* ((class (logand op2 x8664::fulltagmask))
184                                             (high4 (ash op2 (- x8664::ntagbits))))
185                                        (cond ((= class x8664::fulltag-nodeheader-0)
186                                               (svref *nodeheader-0-types* high4))
187                                              ((= class x8664::fulltag-nodeheader-1)
188                                               (svref *nodeheader-1-types* high4))
189                                              ((= class x8664::fulltag-immheader-0)
190                                               (svref *immheader-0-types* high4))
191                                              ((= class x8664::fulltag-immheader-1)
192                                               (svref *immheader-1-types* high4))
193                                              ((= class x8664::fulltag-immheader-2)
194                                               (svref *immheader-2-types* high4))
195                                              (t (list 'bogus op2))))))))
196                       (%error (make-condition 'type-error
197                                               :datum (encoded-gpr-lisp
198                                                       xp
199                                                       (ldb (byte 4 0) op1))
200                                               :expected-type typename)
201                               nil
202                               frame-ptr))))
203                  ((< op1 #xf0)
204                   (%error (make-condition 'type-error
205                                           :datum (encoded-gpr-lisp
206                                                   xp
207                                                   (ldb (byte 4 0) op1))
208                                           :expected-type 'list)
209                           nil
210                           frame-ptr))
211                  (t
212                   (%error (make-condition 'type-error
213                                           :datum (encoded-gpr-lisp
214                                                   xp
215                                                   (ldb (byte 4 0) op1))
216                                           :expected-type 'fixnum)
217                           nil
218                           frame-ptr)))
219            (%error "Unknown trap: #x~x~%xp=~s"
220                    (list (list op0 op1 op2) xp)
221                    frame-ptr))
222          skip))))
223
224
225         
226                 
227                 
228               
229               
230                 
231
232
233
234
235
236                   
237               
238           
Note: See TracBrowser for help on using the repository browser.