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

Last change on this file since 16685 was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

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