Utility predicates for packing: UNBOUNDED-SC-P and UNBOUNDED-TN-P

[sbcl.git] / src / code / hppa-vm.lisp

diff --git a/src/code/hppa-vm.lisp b/src/code/hppa-vm.lisp
index dee7b04..70f0bbc 100644 (file)
--- a/src/code/hppa-vm.lisp
+++ b/src/code/hppa-vm.lisp
@@ -2,34 +2,38 @@
 \f
 (define-alien-type os-context-t (struct os-context-t-struct))
 \f
-;;;; 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)
 \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))
   (sb!sys:without-gcing
-   (let* ((sap (truly-the system-area-pointer
-                          (%primitive sb!kernel::code-instructions code)))
+   (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)))
+              (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)
@@ -42,7 +46,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)))