source: trunk/source/level-1/ppc-error-signal.lisp @ 15232

Last change on this file since 15232 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: 6.5 KB
Line 
1;;; PPC-specific code to handle trap and uuo callbacks.
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20
21
22;;; callback here from C exception handler
23
24(defcallback 
25    %xerr-disp 
26    (:address xp :unsigned-fullword fn-reg :unsigned-fullword pc-or-index :signed-fullword errnum :unsigned-fullword rb :signed-fullword continuable)
27  (block %err-disp
28    (let ((fn (unless (eql fn-reg 0) (xp-gpr-lisp xp fn-reg)))
29          (err-fn (if (eql continuable 0) '%err-disp-internal '%kernel-restart-internal)))
30      (if (eql errnum arch::error-stack-overflow)
31        (handle-stack-overflow xp fn rb)
32        (with-xp-stack-frames (xp fn frame-ptr) ; execute body with dummy stack frame(s)
33          (with-error-reentry-detection
34              (let* ((rb-value (xp-gpr-lisp xp rb))
35                     (res
36                      (cond ((< errnum 0)
37                             (%err-disp-internal errnum nil frame-ptr))
38                            ((logtest errnum arch::error-type-error)
39                             (funcall err-fn 
40                                      #.(car (rassoc 'type-error *kernel-simple-error-classes*))
41                                      (list rb-value (logandc2 errnum arch::error-type-error))
42                                      frame-ptr))
43                            ((eql errnum arch::error-udf)
44                             (funcall err-fn $xfunbnd (list rb-value) frame-ptr))
45                            ((eql errnum arch::error-throw-tag-missing)
46                             (%error (make-condition 'cant-throw-error
47                                                     :tag rb-value)
48                                     nil frame-ptr))
49                            ((eql errnum arch::error-cant-call)
50                             (%error (make-condition 'type-error
51                                                     :datum  rb-value
52                                                     :expected-type '(or symbol function)
53                                                     :format-control
54                                                     "~S is not of type ~S, and can't be FUNCALLed or APPLYed")
55                                     nil frame-ptr))
56                            ((eql errnum arch::error-udf-call)
57                             (return-from %err-disp
58                               (handle-udf-call xp frame-ptr)))
59                            ((eql errnum arch::error-alloc-failed)
60                             (%error (make-condition 
61                                      'simple-storage-condition
62                                      :format-control (%rsc-string $xmemfull))
63                                     nil frame-ptr))
64                            ((eql errnum arch::error-memory-full)
65                             (%error (make-condition 
66                                      'simple-storage-condition
67                                      :format-control (%rsc-string $xnomem))
68                                     nil frame-ptr))
69                            ((or (eql errnum arch::error-fpu-exception-double) 
70                                 (eql errnum arch::error-fpu-exception-single))
71                             (let* ((code-vector (and fn  (uvref fn 0)))
72                                    (instr (if code-vector 
73                                             (uvref code-vector pc-or-index)
74                                             (%get-long (%int-to-ptr pc-or-index)))))
75                               (let* ((minor (ldb (byte 5 1) instr))
76                                      (fra (ldb (byte 5 16) instr))
77                                      (frb (ldb (byte 5 11) instr))
78                                      (frc (ldb (byte 5 6) instr)))
79                                 (declare (fixnum minor fra frb frc))
80                                 (if (= minor 12) ; FRSP
81                                   (%err-disp-internal $xcoerce (list (xp-double-float xp frc) 'short-float) frame-ptr)
82                                   (flet ((coerce-to-op-type (double-arg)
83                                            (if (eql errnum arch::error-fpu-exception-double)
84                                              double-arg
85                                              (handler-case (coerce double-arg 'short-float)
86                                                (error (c) (declare (ignore c)) double-arg)))))
87                                     (multiple-value-bind (status control) (xp-fpscr-info xp)
88                                       (%error (make-condition (fp-condition-from-fpscr status control)
89                                                               :operation (fp-minor-opcode-operation minor)
90                                                               :operands
91                                                               (if (= minor 22)
92                                                                 (list (coerce-to-op-type (xp-double-float xp frb)))
93                                                                 (list (coerce-to-op-type 
94                                                                        (xp-double-float xp fra))
95                                                                       (if (= minor 25)
96                                                                         (coerce-to-op-type 
97                                                                          (xp-double-float xp frc))
98                                                                         (coerce-to-op-type 
99                                                                          (xp-double-float xp frb))))))
100                                               nil
101                                               frame-ptr)))))))
102                            ((eql errnum arch::error-excised-function-call)
103                             (%error "~s: code has been excised." (list (xp-gpr-lisp xp ppc::nfn)) frame-ptr))
104                            ((eql errnum arch::error-too-many-values)
105                             (%err-disp-internal $xtoomanyvalues (list rb-value) frame-ptr))
106                            (t (%error "Unknown error #~d with arg: ~d" (list errnum rb-value) frame-ptr)))))
107                (setf (xp-gpr-lisp xp rb) res) ; munge register for continuation
108                )))))))
109
110
111
112(defun handle-udf-call (xp frame-ptr)
113  (let* ((args (xp-argument-list xp))
114         (values (multiple-value-list
115                  (%kernel-restart-internal
116                   $xudfcall
117                   (list (maybe-setf-name (xp-gpr-lisp xp ppc::fname)) args)
118                   frame-ptr)))
119         (stack-argcnt (max 0 (- (length args) 3)))
120         (vsp (%i+ (xp-gpr-lisp xp ppc::vsp) stack-argcnt))
121         (f #'(lambda (values) (apply #'values values))))
122    (setf (xp-gpr-lisp xp ppc::vsp) vsp
123          (xp-gpr-lisp xp ppc::nargs) 1
124          (xp-gpr-lisp xp ppc::arg_z) values
125          (xp-gpr-lisp xp ppc::nfn) f)
126    ;; handle_uuo() (in the lisp kernel) will not bump the PC here.
127    (setf (xp-gpr-lisp xp #+linuxppc-target #$PT_NIP #+darwinppc-target -2)
128          (uvref f 0))))
129
130
131
132
133
134
135;;; rb is the register number of the stack that overflowed.
136;;; xp & fn are passed so that we can establish error context.
137(defun handle-stack-overflow (xp fn rb)
138  (unwind-protect
139       (with-xp-stack-frames (xp fn frame-ptr) ; execute body with dummy stack frame(s)
140         (%error
141          (make-condition
142           'stack-overflow-condition 
143           :format-control "Stack overflow on ~a stack."
144           :format-arguments (list
145                              (if (eql rb ppc::sp)
146                                "control"
147                                (if (eql rb ppc::vsp)
148                                  "value"
149                                  (if (eql rb ppc::tsp)
150                                    "temp"
151                                    "unknown")))))
152          nil frame-ptr))
153    (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit)
154             :unsigned-fullword rb
155             :void)))
156
157
Note: See TracBrowser for help on using the repository browser.