Commit cea1ec65 authored by Nikodemus Siivola's avatar Nikodemus Siivola
Browse files

1.0.24.16: updates on how we deal with fixup on HPPA 

 * Patch by Larry Valkama.
parent cfc48ce6

src/code/hppa-vm.lisp

+16 −5
Original line number Diff line number Diff line
@@ -13,7 +13,7 @@ 
  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))
@@ -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)))))))))



(define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-int)

  (context (* os-context-t)))

src/compiler/generic/genesis.lisp

+26 −14
Original line number Diff line number Diff line
@@ -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))))

            (assert (<= 0 low-bits (1- (ash 1 4)))))

          (setf (bvref-32 gspace-bytes gspace-byte-offset)

                  (logior (ash low-bits 17)

                (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)))))

                                #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

version.lisp-expr

+1 −1
Original line number Diff line number Diff line
@@ -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"