1.0.24.16: updates on how we deal with fixup on HPPA

 * Patch by Larry Valkama.

diff --git a/src/code/hppa-vm.lisp b/src/code/hppa-vm.lisp
index f2a3b3a..5573841 100644 (file)
--- a/src/code/hppa-vm.lisp
+++ b/src/code/hppa-vm.lisp
@@ -13,7 +13,7 @@
   nil)
 \f
 ;;;; 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))
@@ -23,12 +23,21 @@
      (setf (sap-ref-32 sap offset)
            (ecase kind
              (:load
-              (logior (ash (ldb (byte 11 0) value) 1)
-                      (logand inst #xffffc000)))
+              (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 low-bits 17)
+                (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)
@@ -41,7 +50,9 @@
               (let ((bits (ldb (byte 9 2) value)))
                 (aver (zerop (ldb (byte 2 0) value)))
                 (logior (ash bits 3)
-                        (logand inst #xffe0e002)))))))))
+                        (mask-field (byte 1 1) inst)
+                        (mask-field (byte 3 13) inst)
+                        (mask-field (byte 11 21) inst)))))))))
 \f
 (define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-int)
   (context (* os-context-t)))

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 51ccf01..ecf2735 100644 (file)
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -1728,32 +1728,44 @@ core and return a descriptor to it."
        (ecase kind
          (:load
           (setf (bvref-32 gspace-bytes gspace-byte-offset)
-                (logior (ash (ldb (byte 11 0) value) 1)
-                        (logand (bvref-32 gspace-bytes gspace-byte-offset)
-                                #xffffc000))))
+                (logior (mask-field (byte 18 14)
+                                    (bvref-32 gspace-bytes gspace-byte-offset))
+                        (if (< value 0)
+                          (1+ (ash (ldb (byte 13 0) value) 1))
+                          (ash (ldb (byte 13 0) value) 1)))))
+         (:load11u
+          (setf (bvref-32 gspace-bytes gspace-byte-offset)
+                (logior (mask-field (byte 18 14)
+                                    (bvref-32 gspace-bytes gspace-byte-offset))
+                        (if (< value 0)
+                          (1+ (ash (ldb (byte 10 0) value) 1))
+                          (ash (ldb (byte 11 0) value) 1)))))
          (:load-short
           (let ((low-bits (ldb (byte 11 0) value)))
-            (assert (<= 0 low-bits (1- (ash 1 4))))
-            (setf (bvref-32 gspace-bytes gspace-byte-offset)
-                  (logior (ash low-bits 17)
-                          (logand (bvref-32 gspace-bytes gspace-byte-offset)
-                                  #xffe0ffff)))))
+            (assert (<= 0 low-bits (1- (ash 1 4)))))
+          (setf (bvref-32 gspace-bytes gspace-byte-offset)
+                (logior (ash (dpb (ldb (byte 4 0) value)
+                                  (byte 4 1)
+                                  (ldb (byte 1 4) value)) 17)
+                        (logand (bvref-32 gspace-bytes gspace-byte-offset)
+                                #xffe0ffff))))
          (:hi
           (setf (bvref-32 gspace-bytes gspace-byte-offset)
-                (logior (ash (ldb (byte 5 13) value) 16)
+                (logior (mask-field (byte 11 21)
+                                    (bvref-32 gspace-bytes gspace-byte-offset))
+                        (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 (bvref-32 gspace-bytes gspace-byte-offset)
-                                #xffe00000))))
+                        (ldb (byte 1 31) value))))
          (:branch
           (let ((bits (ldb (byte 9 2) value)))
             (assert (zerop (ldb (byte 2 0) value)))
             (setf (bvref-32 gspace-bytes gspace-byte-offset)
                   (logior (ash bits 3)
-                          (logand (bvref-32 gspace-bytes gspace-byte-offset)
-                                  #xffe0e002)))))))
+                          (mask-field (byte 1 1) (bvref-32 gspace-bytes gspace-byte-offset))
+                          (mask-field (byte 3 13) (bvref-32 gspace-bytes gspace-byte-offset))
+                          (mask-field (byte 11 21) (bvref-32 gspace-bytes gspace-byte-offset))))))))
       (:mips
        (ecase kind
          (:jump

diff --git a/version.lisp-expr b/version.lisp-expr
index de2f387..f53f1cb 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.24.15"
+"1.0.24.16"