X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fhppa-vm.lisp;h=70f0bbc2752b2c2205467f4eb62cd00244d8607e;hb=cee8ef591040db9a79cdd19297867672a9529051;hp=62a2b5c6335a2971d339f56b5114cf2619704452;hpb=338732358d49ab202fe55c3581294597d63aec6b;p=sbcl.git

diff --git a/src/code/hppa-vm.lisp b/src/code/hppa-vm.lisp
index 62a2b5c..70f0bbc 100644
--- a/src/code/hppa-vm.lisp
+++ b/src/code/hppa-vm.lisp
@@ -2,47 +2,53 @@
 
 (define-alien-type os-context-t (struct os-context-t-struct))
 
-;;;; MACHINE-TYPE and MACHINE-VERSION
+;;;; MACHINE-TYPE
 
 (defun machine-type ()
   "Returns a string describing the type of the local machine."
   "HPPA")
-
-;;; support for CL:MACHINE-VERSION defined OAOO elsewhere
-(defun get-machine-version ()
-  nil)
 
 ;;;; FIXUP-CODE-OBJECT
-
+;FIX-lav: unify code with genesis.lisp fixup
 (defun fixup-code-object (code offset value kind)
   (unless (zerop (rem offset n-word-bytes))
     (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)))
+   (let* ((sap (%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)))
-		(assert (<= 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)))
-		(assert (zerop (ldb (byte 2 0) value)))
-		(logior (ash bits 3)
-			(logand inst #xffe0e002)))))))))
+           (ecase kind
+             (:load
+              (logior (mask-field (byte 18 14) value)
+                      (if (< value 0)
+                        (1+ (ash (ldb (byte 13 0) value) 1))
+                        (ash (ldb (byte 13 0) value) 1))))
+             (:load11u
+              (logior (if (< value 0)
+                          (1+ (ash (ldb (byte 10 0) value) 1))
+                          (ash (ldb (byte 11 0) value) 1))
+                      (mask-field (byte 18 14) inst)))
+             (:load-short
+              (let ((low-bits (ldb (byte 11 0) value)))
+                (aver (<= 0 low-bits (1- (ash 1 4))))
+                (logior (ash (dpb (ldb (byte 4 0) value)
+                                  (byte 4 1)
+                                  (ldb (byte 1 4) value)) 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)
+                        (mask-field (byte 1 1) inst)
+                        (mask-field (byte 3 13) inst)
+                        (mask-field (byte 11 21) inst)))))))))
 
 (define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-int)
   (context (* os-context-t)))
@@ -79,21 +85,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)))))))