diff --git a/code/pmax-vm.lisp b/code/pmax-vm.lisp index 5b440838cfa9062fcecd22e5270ddeb67973a1ac..83579713560a3c72cb028e47720b03cc9bf6ccd3 100644 --- a/code/pmax-vm.lisp +++ b/code/pmax-vm.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pmax-vm.lisp,v 1.3 1990/11/26 15:16:43 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pmax-vm.lisp,v 1.4 1990/11/26 18:55:08 wlott Exp $ ;;; ;;; This file contains the PMAX specific runtime stuff. ;;; @@ -57,36 +57,29 @@ ;;; Given the sigcontext, extract the internal error arguments from the ;;; instruction stream. ;;; -(defun internal-error-arguments (scp) - (alien-bind ((sc (make-alien 'mach:sigcontext - #.(c-sizeof 'mach:sigcontext) - scp) - mach:sigcontext - t) - (regs (mach:sigcontext-regs (alien-value sc)) mach:int-array t)) - (let* ((original-pc (alien-access (mach:sigcontext-pc (alien-value sc)))) - (pc (sap+ original-pc - (+ (if (logbitp 31 - (alien-access - (mach:sigcontext-cause - (alien-value sc)))) - 4 - 0) - (if (= (sap-ref-8 original-pc 4) 255) - 1 - 0)))) - (length (sap-ref-8 pc 4)) - (vector (make-array length :element-type '(unsigned-byte 8)))) - (copy-from-system-area pc (* vm:byte-bits 5) - vector (* vm:word-bits - vm:vector-data-offset) - (* length vm: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))))))) +(defun internal-error-arguments (sc) + (alien-bind ((sc sc mach:sigcontext t)) + (let ((pc (alien-access (mach:sigcontext-pc (alien-value sc))))) + (declare (type system-area-pointer pc)) + (when (logbitp 31 + (alien-access (mach:sigcontext-cause (alien-value sc)))) + (setf pc (sap+ pc 4))) + (when (= (sap-ref-8 pc 4) 255) + (setf pc (sap+ pc 1))) + (let* ((length (sap-ref-8 pc 4)) + (vector (make-array length :element-type '(unsigned-byte 8)))) + (declare (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)) + (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))))))))