;;;
;;; Copyright 1994-2009 Clozure Associates
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;     http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

(in-package "CCL")



;;; callback here from C exception handler

(defcallback 
    %xerr-disp 
    (:address xp :unsigned-fullword fn-reg :unsigned-fullword pc-or-index :signed-fullword errnum :unsigned-fullword rb :signed-fullword continuable)
  (block %err-disp
    (let ((fn (unless (eql fn-reg 0) (xp-gpr-lisp xp fn-reg)))
	  (err-fn (if (eql continuable 0) '%err-disp-internal '%kernel-restart-internal)))
      (if (eql errnum arch::error-stack-overflow)
	(handle-stack-overflow xp fn rb)
	(with-xp-stack-frames (xp fn frame-ptr)	; execute body with dummy stack frame(s)
	  (with-error-reentry-detection
	      (let* ((rb-value (xp-gpr-lisp xp rb))
		     (res
		      (cond ((< errnum 0)
			     (%err-disp-internal errnum nil frame-ptr))
			    ((logtest errnum arch::error-type-error)
			     (funcall err-fn 
				      #.(car (rassoc 'type-error *kernel-simple-error-classes*))
				      (list rb-value (logandc2 errnum arch::error-type-error))
				      frame-ptr))
			    ((eql errnum arch::error-udf)
			     (funcall err-fn $xfunbnd (list rb-value) frame-ptr))
			    ((eql errnum arch::error-throw-tag-missing)
			     (%error (make-condition 'cant-throw-error
						     :tag rb-value)
				     nil frame-ptr))
			    ((eql errnum arch::error-cant-call)
			     (%error (make-condition 'type-error
						     :datum  rb-value
						     :expected-type '(or symbol function)
						     :format-control
						     "~S is not of type ~S, and can't be FUNCALLed or APPLYed")
				     nil frame-ptr))
			    ((eql errnum arch::error-udf-call)
			     (return-from %err-disp
			       (handle-udf-call xp frame-ptr)))
			    ((eql errnum arch::error-alloc-failed)
			     (%error (make-condition 
				      'simple-storage-condition
				      :format-control (%rsc-string $xmemfull))
				     nil frame-ptr))
			    ((eql errnum arch::error-memory-full)
			     (%error (make-condition 
				      'simple-storage-condition
				      :format-control (%rsc-string $xnomem))
				     nil frame-ptr))
			    ((or (eql errnum arch::error-fpu-exception-double) 
				 (eql errnum arch::error-fpu-exception-single))
			     (let* ((code-vector (and fn  (uvref fn 0)))
				    (instr (if code-vector 
					     (uvref code-vector pc-or-index)
					     (%get-long (%int-to-ptr pc-or-index)))))
			       (let* ((minor (ldb (byte 5 1) instr))
				      (fra (ldb (byte 5 16) instr))
				      (frb (ldb (byte 5 11) instr))
				      (frc (ldb (byte 5 6) instr)))
				 (declare (fixnum minor fra frb frc))
				 (if (= minor 12) ; FRSP
				   (%err-disp-internal $xcoerce (list (xp-double-float xp frc) 'short-float) frame-ptr)
				   (flet ((coerce-to-op-type (double-arg)
					    (if (eql errnum arch::error-fpu-exception-double)
					      double-arg
					      (handler-case (coerce double-arg 'short-float)
						(error (c) (declare (ignore c)) double-arg)))))
				     (multiple-value-bind (status control) (xp-fpscr-info xp)
				       (%error (make-condition (fp-condition-from-fpscr status control)
							       :operation (fp-minor-opcode-operation minor)
							       :operands
                                                               (if (= minor 22)
                                                                 (list (coerce-to-op-type (xp-double-float xp frb)))
                                                                 (list (coerce-to-op-type 
                                                                        (xp-double-float xp fra))
                                                                       (if (= minor 25)
                                                                         (coerce-to-op-type 
                                                                          (xp-double-float xp frc))
                                                                         (coerce-to-op-type 
                                                                          (xp-double-float xp frb))))))
					       nil
					       frame-ptr)))))))
			    ((eql errnum arch::error-excised-function-call)
			     (%error "~s: code has been excised." (list (xp-gpr-lisp xp ppc::nfn)) frame-ptr))
			    ((eql errnum arch::error-too-many-values)
			     (%err-disp-internal $xtoomanyvalues (list rb-value) frame-ptr))
			    (t (%error "Unknown error #~d with arg: ~d" (list errnum rb-value) frame-ptr)))))
		(setf (xp-gpr-lisp xp rb) res) ; munge register for continuation
		)))))))



(defun handle-udf-call (xp frame-ptr)
  (let* ((args (xp-argument-list xp))
         (values (multiple-value-list
                  (%kernel-restart-internal
                   $xudfcall
                   (list (maybe-setf-name (xp-gpr-lisp xp ppc::fname)) args)
                   frame-ptr)))
         (stack-argcnt (max 0 (- (length args) 3)))
         (vsp (%i+ (xp-gpr-lisp xp ppc::vsp) stack-argcnt))
         (f #'(lambda (values) (apply #'values values))))
    (setf (xp-gpr-lisp xp ppc::vsp) vsp
          (xp-gpr-lisp xp ppc::nargs) 1
          (xp-gpr-lisp xp ppc::arg_z) values
          (xp-gpr-lisp xp ppc::nfn) f)
    ;; handle_uuo() (in the lisp kernel) will not bump the PC here.
    (setf (xp-gpr-lisp xp #+linuxppc-target #$PT_NIP #+darwinppc-target -2)
	  (uvref f 0))))






;;; rb is the register number of the stack that overflowed.
;;; xp & fn are passed so that we can establish error context.
(defun handle-stack-overflow (xp fn rb)
  (unwind-protect
       (with-xp-stack-frames (xp fn frame-ptr) ; execute body with dummy stack frame(s)
	 (%error
	  (make-condition
	   'stack-overflow-condition 
	   :format-control "Stack overflow on ~a stack."
	   :format-arguments (list
			      (if (eql rb ppc::sp)
				"control"
				(if (eql rb ppc::vsp)
				  "value"
				  (if (eql rb ppc::tsp)
				    "temp"
				    "unknown")))))
	  nil frame-ptr))
    (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit)
	     :unsigned-fullword rb
	     :void)))


