X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fhppa-vm.lisp;h=dee7b040b2a82a4c9d266b690ada668bf4cb6c0f;hb=48ec282d877900caf5ea4ab42e9d87e566ce6b43;hp=9f30c9a5f34160159c46311bbd7f88ad7320ecdb;hpb=6365d636fa30ff3e2c2ebc9668f978fa0ebc7a0e;p=sbcl.git diff --git a/src/code/hppa-vm.lisp b/src/code/hppa-vm.lisp index 9f30c9a..dee7b04 100644 --- a/src/code/hppa-vm.lisp +++ b/src/code/hppa-vm.lisp @@ -19,30 +19,30 @@ (error "Unaligned instruction? offset=#x~X." offset)) (sb!sys:without-gcing (let* ((sap (truly-the system-area-pointer - (%primitive sb!kernel::code-instructions code))) - (inst (sap-ref-32 sap offset))) + (%primitive sb!kernel::code-instructions code))) + (inst (sap-ref-32 sap offset))) (setf (sap-ref-32 sap offset) - (ecase kind - (:load - (logior (ash (ldb (byte 11 0) value) 1) - (logand inst #xffffc000))) - (:load-short - (let ((low-bits (ldb (byte 11 0) value))) - (aver (<= 0 low-bits (1- (ash 1 4)))) - (logior (ash low-bits 17) - (logand inst #xffe0ffff)))) - (:hi - (logior (ash (ldb (byte 5 13) value) 16) - (ash (ldb (byte 2 18) value) 14) - (ash (ldb (byte 2 11) value) 12) - (ash (ldb (byte 11 20) value) 1) - (ldb (byte 1 31) value) - (logand inst #xffe00000))) - (:branch - (let ((bits (ldb (byte 9 2) value))) - (aver (zerop (ldb (byte 2 0) value))) - (logior (ash bits 3) - (logand inst #xffe0e002))))))))) + (ecase kind + (:load + (logior (ash (ldb (byte 11 0) value) 1) + (logand inst #xffffc000))) + (:load-short + (let ((low-bits (ldb (byte 11 0) value))) + (aver (<= 0 low-bits (1- (ash 1 4)))) + (logior (ash low-bits 17) + (logand inst #xffe0ffff)))) + (:hi + (logior (ash (ldb (byte 5 13) value) 16) + (ash (ldb (byte 2 18) value) 14) + (ash (ldb (byte 2 11) value) 12) + (ash (ldb (byte 11 20) value) 1) + (ldb (byte 1 31) value) + (logand inst #xffe00000))) + (:branch + (let ((bits (ldb (byte 9 2) value))) + (aver (zerop (ldb (byte 2 0) value))) + (logior (ash bits 3) + (logand inst #xffe0e002))))))))) (define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-int) (context (* os-context-t))) @@ -79,21 +79,21 @@ ;;; ;;; Given the sigcontext, extract the internal error arguments from the ;;; instruction stream. -;;; +;;; (defun internal-error-args (context) (declare (type (alien (* os-context-t)) context)) (let ((pc (context-pc context))) (declare (type system-area-pointer pc)) (let* ((length (sap-ref-8 pc 4)) - (vector (make-array length :element-type '(unsigned-byte 8)))) + (vector (make-array length :element-type '(unsigned-byte 8)))) (declare (type (unsigned-byte 8) length) - (type (simple-array (unsigned-byte 8) (*)) vector)) + (type (simple-array (unsigned-byte 8) (*)) vector)) (copy-ub8-from-system-area pc 5 vector 0 length) (let* ((index 0) - (error-number (sb!c:read-var-integer vector index))) - (collect ((sc-offsets)) - (loop - (when (>= index length) - (return)) - (sc-offsets (sb!c:read-var-integer vector index))) - (values error-number (sc-offsets))))))) + (error-number (sb!c:read-var-integer vector index))) + (collect ((sc-offsets)) + (loop + (when (>= index length) + (return)) + (sc-offsets (sb!c:read-var-integer vector index))) + (values error-number (sc-offsets)))))))