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

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

Change "OpenMCL" to "Clozure CL" in comments and docstrings.

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