Skip to content
Snippets Groups Projects
Commit 929fb85f authored by wlott's avatar wlott
Browse files

Added stuff to INTERNAL-ERROR-ARGUMENTS to deterine if the internal error

was signaled due to an unimp, a tcc, or a taddcctv instruction, and act
accordingly.
parent 3a1b73b5
No related branches found
No related tags found
No related merge requests found
;;; -*- Package: VM -*- ;;; -*- Package: SPARC -*-
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at ;;; This code was written as part of the Spice Lisp project at
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC). ;;; Scott Fahlman (FAHLMAN@CMUC).
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sparc-vm.lisp,v 1.5 1990/12/06 17:40:17 ram Exp $ ;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sparc-vm.lisp,v 1.6 1990/12/17 19:34:16 wlott Exp $
;;; ;;;
;;; This file contains the SPARC specific runtime stuff. ;;; This file contains the SPARC specific runtime stuff.
;;; ;;;
...@@ -54,6 +54,23 @@ ...@@ -54,6 +54,23 @@
;;; instruction stream. ;;; instruction stream.
;;; ;;;
(defun internal-error-arguments (sc) (defun internal-error-arguments (sc)
(alien-bind ((sc sc mach:sigcontext t))
(let* ((pc (alien-access (mach:sigcontext-pc (alien-value sc))))
(bad-inst (sap-ref-32 pc 0))
(op (ldb (byte 2 30) bad-inst))
(op2 (ldb (byte 3 22) bad-inst))
(op3 (ldb (byte 6 19) bad-inst)))
(cond ((and (= op #b00) (= op2 #b000))
(args-for-unimp-inst sc))
((and (= op #b10) (= (ldb (byte 4 2) op3) #b1000))
(args-for-tagged-add-inst sc bad-inst))
((and (= op #b10) (= op3 #b111010))
(args-for-tcc-inst bad-inst))
(t
(values (error-number-or-lose 'unknown-error)
nil))))))
(defun args-for-unimp-inst (sc)
(alien-bind ((sc sc mach:sigcontext t)) (alien-bind ((sc sc mach:sigcontext t))
(let* ((pc (alien-access (mach:sigcontext-pc (alien-value sc)))) (let* ((pc (alien-access (mach:sigcontext-pc (alien-value sc))))
(length (sap-ref-8 pc 4)) (length (sap-ref-8 pc 4))
...@@ -61,18 +78,58 @@ ...@@ -61,18 +78,58 @@
(declare (type system-area-pointer pc) (declare (type system-area-pointer pc)
(type (unsigned-byte 8) length) (type (unsigned-byte 8) length)
(type (simple-array (unsigned-byte 8) (*)) vector)) (type (simple-array (unsigned-byte 8) (*)) vector))
(copy-from-system-area pc (* vm:byte-bits 5) (copy-from-system-area pc (* sparc:byte-bits 5)
vector (* vm:word-bits vector (* sparc:word-bits
vm:vector-data-offset) sparc:vector-data-offset)
(* length vm:byte-bits)) (* length sparc:byte-bits))
(let* ((index 0) (let* ((index 0)
(error-number (c::read-var-integer vector index))) (error-number (c::read-var-integer vector index)))
(collect ((sc-offsets)) (collect ((sc-offsets))
(loop (loop
(when (>= index length) (when (>= index length)
(return)) (return))
(sc-offsets (c::read-var-integer vector index))) (sc-offsets (c::read-var-integer vector index)))
(values error-number (sc-offsets))))))) (values error-number (sc-offsets)))))))
(defun args-for-tagged-add-inst (sc bad-inst)
(alien-bind ((sc sc mach:sigcontext t)
(regs (mach:sigcontext-regs (alien-value sc)) mach:int-array t))
(let* ((rs1 (ldb (byte 5 14) bad-inst))
(op1 (di::make-lisp-obj
(alien-access
(mach:int-array-ref (alien-value regs)
rs1)))))
(if (fixnump op1)
(if (zerop (ldb (byte 1 13) bad-inst))
(let* ((rs2 (ldb (byte 5 0) bad-inst))
(op2 (di::make-lisp-obj
(alien-access
(mach:int-array-ref (alien-value regs)
rs2)))))
(if (fixnump op2)
(values (error-number-or-lose 'unknown-error)
nil)
(values (error-number-or-lose 'object-not-fixnum-error)
(list (c::make-sc-offset
sparc:descriptor-reg-sc-number
rs2)))))
(values (error-number-or-lose 'unknown-error)
nil))
(values (error-number-or-lose 'object-not-fixnum-error)
(list (c::make-sc-offset sparc:descriptor-reg-sc-number
rs1)))))))
(defun args-for-tcc-inst (bad-inst)
(let* ((trap-number (ldb (byte 8 0) bad-inst))
(reg (ldb (byte 5 8) bad-inst)))
(values (case trap-number
(#.sparc:object-not-list-trap
(error-number-or-lose 'object-not-list-error))
(#.sparc:object-not-structure-trap
(error-number-or-lose 'object-not-structure-error))
(t
(error-number-or-lose 'unknown-error)))
(list (c::make-sc-offset sparc:descriptor-reg-sc-number reg)))))
;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment