From 929fb85f1e74f50f5b431f45ddc48b30f235d8f5 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Mon, 17 Dec 1990 19:34:16 +0000 Subject: [PATCH] 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. --- code/sparc-vm.lisp | 79 +++++++++++++++++++++++++++++++++++++++------- 1 file changed, 68 insertions(+), 11 deletions(-) diff --git a/code/sparc-vm.lisp b/code/sparc-vm.lisp index 72ec513e6..6033dbad2 100644 --- a/code/sparc-vm.lisp +++ b/code/sparc-vm.lisp @@ -1,4 +1,4 @@ -;;; -*- Package: VM -*- +;;; -*- Package: SPARC -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the Spice Lisp project at @@ -7,7 +7,7 @@ ;;; 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. ;;; @@ -54,6 +54,23 @@ ;;; instruction stream. ;;; (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)) (let* ((pc (alien-access (mach:sigcontext-pc (alien-value sc)))) (length (sap-ref-8 pc 4)) @@ -61,18 +78,58 @@ (declare (type system-area-pointer pc) (type (unsigned-byte 8) length) (type (simple-array (unsigned-byte 8) (*)) vector)) - (copy-from-system-area pc (* vm:byte-bits 5) - vector (* vm:word-bits - vm:vector-data-offset) - (* length vm:byte-bits)) + (copy-from-system-area pc (* sparc:byte-bits 5) + vector (* sparc:word-bits + sparc:vector-data-offset) + (* length sparc:byte-bits)) (let* ((index 0) (error-number (c::read-var-integer vector index))) (collect ((sc-offsets)) - (loop - (when (>= index length) - (return)) - (sc-offsets (c::read-var-integer vector index))) - (values error-number (sc-offsets))))))) + (loop + (when (>= index length) + (return)) + (sc-offsets (c::read-var-integer vector index))) + (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 -- GitLab