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

Last change on this file was 16782, checked in by rme, 3 years ago

Undo r16779.

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