Commit 4d5efa2b authored by Nikodemus Siivola's avatar Nikodemus Siivola
Browse files

1.0.24.37: full raw-instance-slot support on HPPA 

 * Patch by Larry Valkama.
parent ee3f2e03

src/compiler/hppa/cell.lisp

+83 −73
Original line number Diff line number Diff line
@@ -257,15 +257,28 @@ 




;;;; raw instance slot accessors



(macrolet ((fix-storage (inc-offset-by)

             `(progn

                (loadw offset object 0 instance-pointer-lowtag)

                (inst srl offset n-widetag-bits offset)

                (inst sll offset 2 offset)

                (inst sub offset index offset)

                (inst addi ,inc-offset-by offset offset)

                (inst add offset object lip)))

(macrolet ((lfloat (imm base dst &key side)

             `(cond

                ((< ,imm (ash 1 4))

                  (inst flds ,imm ,base ,dst :side ,side))

                ((and (< ,imm (ash 1 13))

                      (> ,imm 0))

                  (progn

                    (inst li ,imm offset)

                    (inst fldx offset ,base ,dst :side ,side)))

                (t

                  (error "inst fldx cant handle offset-register loaded with immediate ~s" ,imm))))

           (sfloat (src imm base &key side)

             `(cond

                ((< ,imm (ash 1 4))

                  (inst fsts ,src ,imm ,base :side ,side))

                ((and (< ,imm (ash 1 13))

                      (> ,imm 0))

                  (progn

                    (inst ldo ,imm zero-tn offset)

                    (inst fstx ,src offset ,base :side ,side)))

                (t

                  (error "inst fstx cant handle offset-register loaded with immediate ~s" ,imm))))

           (raw-instance ((type inc-offset-by set &optional complex)

                          &body body)

             (let ((name (symbolicate "RAW-INSTANCE-"
@@ -313,92 +326,89 @@ 
    (move value result))



  (raw-instance (single -1 nil)

    (inst li (- (* instance-slots-offset n-word-bytes)

                instance-pointer-lowtag) offset)

    (inst fldx offset lip value))

    (let ((io (- (* instance-slots-offset n-word-bytes)

                 instance-pointer-lowtag)))

      (lfloat io lip value)))



  (raw-instance (single -1 t)

    (inst li (- (* instance-slots-offset n-word-bytes)

                instance-pointer-lowtag) offset)

    (inst fstx value offset lip)

    (let ((io (- (* instance-slots-offset n-word-bytes)

                 instance-pointer-lowtag)))

      (sfloat value io lip))

    (unless (location= result value)

      (inst funop :copy value result)))



  (raw-instance (double -2 nil)

    (inst fldx object index value)

    (inst fldx offset lip value))

    (let ((io (- (* instance-slots-offset n-word-bytes)

                 instance-pointer-lowtag)))

      (lfloat io lip value)))



  (raw-instance (double -2 t)

    (inst fldx offset lip value)

    (inst fldx index object value)

    (inst funop :copy value result))

    (let ((io (- (* instance-slots-offset n-word-bytes)

                 instance-pointer-lowtag)))

      (sfloat value io lip :side 0))

    (let ((io (- (* (1+ instance-slots-offset) n-word-bytes)

                 instance-pointer-lowtag)))

      (sfloat value io lip :side 1))

    (unless (location= result value)

      (inst funop :copy value result)))



  (raw-instance (single -2 nil complex-single)

    (inst li (- (* instance-slots-offset n-word-bytes)

                instance-pointer-lowtag) offset)

    (inst fldx offset lip (complex-single-reg-real-tn value))

    (inst li (- (* (1+ instance-slots-offset) n-word-bytes)

                instance-pointer-lowtag) offset)

    (inst fldx offset lip (complex-single-reg-imag-tn value)))

    (let ((io (- (* instance-slots-offset n-word-bytes)

                 instance-pointer-lowtag)))

      (lfloat io lip (complex-single-reg-real-tn value)))

    (let ((io (- (* (1+ instance-slots-offset) n-word-bytes)

                 instance-pointer-lowtag)))

      (lfloat io lip (complex-single-reg-imag-tn value))))



  (raw-instance (single -2 t complex-single)

    (let ((value-real (complex-single-reg-real-tn value))

          (result-real (complex-single-reg-real-tn result)))

      (inst li (- (* instance-slots-offset n-word-bytes)

                  instance-pointer-lowtag) offset)

      (inst fstx value-real offset lip)

          (result-real (complex-single-reg-real-tn result))

          (io (- (* instance-slots-offset n-word-bytes)

                 instance-pointer-lowtag)))



      (sfloat value-real io lip)

      (unless (location= result-real value-real)

        (inst funop :copy value-real result-real)))

    (let ((value-imag (complex-single-reg-imag-tn value))

          (result-imag (complex-single-reg-imag-tn result)))

      (inst li (- (* (1+ instance-slots-offset) n-word-bytes)

                  instance-pointer-lowtag) offset)

      (inst fstx value-imag offset lip)

          (result-imag (complex-single-reg-imag-tn result))

          (io (- (* (1+ instance-slots-offset) n-word-bytes)

                 instance-pointer-lowtag)))

      (sfloat value-imag io lip)

      (unless (location= result-imag value-imag)

        (inst funop :copy value-imag result-imag))))



  (raw-instance (double -4 nil complex-double)

    (let ((immediate-offset (- (* instance-slots-offset n-word-bytes)

    (let ((r0 (- (* instance-slots-offset n-word-bytes)

                 instance-pointer-lowtag))

          (r1 (- (* (+ instance-slots-offset 1) n-word-bytes)

                 instance-pointer-lowtag))

          (i0 (- (* (+ instance-slots-offset 2) n-word-bytes)

                 instance-pointer-lowtag))

          (i1 (- (* (+ instance-slots-offset 3) n-word-bytes)

                 instance-pointer-lowtag)))

      (inst li immediate-offset offset)

      (inst fldx offset lip (complex-double-reg-real-tn value)))

    (let ((immediate-offset (+ 4 (- (* (1+ instance-slots-offset)

           n-word-bytes) instance-pointer-lowtag))))

      (inst li immediate-offset offset)

      (inst fldx offset lip (complex-double-reg-real-tn value)))

    (let ((immediate-offset (- (* (+ instance-slots-offset 2) n-word-bytes)

                               instance-pointer-lowtag)))

      (inst li immediate-offset offset)

      (inst fldx offset lip (complex-double-reg-imag-tn value)))

    (let ((immediate-offset (+ 4 (- (* (+ instance-slots-offset 3)

           n-word-bytes) instance-pointer-lowtag))))

      (inst li immediate-offset offset)

      (inst fldx offset lip (complex-double-reg-imag-tn value))))

      (lfloat r0 lip (complex-double-reg-real-tn value) :side 0)

      (lfloat r1 lip (complex-double-reg-real-tn value) :side 1)

      (lfloat i0 lip (complex-double-reg-imag-tn value) :side 0)

      (lfloat i1 lip (complex-double-reg-imag-tn value) :side 1)))



  (raw-instance (double -4 t complex-double)

    (let ((value-real  (complex-double-reg-real-tn value))

          (result-real (complex-double-reg-real-tn result)))

      (let ((immediate-offset (- (* instance-slots-offset n-word-bytes)

          (result-real (complex-double-reg-real-tn result))

          (value-imag (complex-double-reg-imag-tn value))

          (result-imag (complex-double-reg-imag-tn result))

          (r0 (- (* instance-slots-offset n-word-bytes)

                 instance-pointer-lowtag))

          (r1 (- (* (+ instance-slots-offset 1) n-word-bytes)

                 instance-pointer-lowtag))

          (i0 (- (* (+ instance-slots-offset 2) n-word-bytes)

                 instance-pointer-lowtag))

          (i1 (- (* (+ instance-slots-offset 3) n-word-bytes)

                      instance-pointer-lowtag)))

        (inst li immediate-offset offset)

        (inst fldx offset lip value-real))

      (let ((immediate-offset (+ 4 (- (* (1+ instance-slots-offset)

              n-word-bytes) instance-pointer-lowtag))))

        (inst li immediate-offset offset)

        (inst fldx offset lip value-real))



      (sfloat value-real r0 lip :side 0)

      (sfloat value-real r1 lip :side 1)

      (sfloat value-imag i0 lip :side 0)

      (sfloat value-imag i1 lip :side 1)

      (unless (location= result-real value-real)

        (inst funop :copy value-real result-real)))

    (let ((value-imag (complex-double-reg-imag-tn value))

          (result-imag (complex-double-reg-imag-tn result)))

      (let ((immediate-offset (- (* (+ instance-slots-offset 2) n-word-bytes)

                                 instance-pointer-lowtag)))

        (inst li immediate-offset offset)

        (inst fldx offset lip value-imag))



      (let ((immediate-offset (+ 4 (- (* (+ instance-slots-offset 3)

             n-word-bytes) instance-pointer-lowtag))))

        (inst li immediate-offset offset)

        (inst fldx offset lip value-imag))

        (inst funop :copy value-real result-real))

      (unless (location= result-imag value-imag)

         (inst funop :copy value-imag result-imag)))))

src/compiler/hppa/float.lisp

+2 −2
Original line number Diff line number Diff line
@@ -132,10 +132,10 @@ 
                  :offset (1+ (tn-offset x))))



(defun complex-double-reg-real-tn (x)

  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)

  (make-random-tn :kind :normal :sc (sc-or-lose 'complex-double-reg)

                  :offset (tn-offset x)))

(defun complex-double-reg-imag-tn (x)

  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)

  (make-random-tn :kind :normal :sc (sc-or-lose 'complex-double-reg)

                  :offset (1+ (tn-offset x))))



(macrolet

src/compiler/hppa/insts.lisp

+3 −1
Original line number Diff line number Diff line
@@ -34,7 +34,9 @@ 
    (fp-single-zero (values 0 nil))

    (single-reg (values (tn-offset tn) nil))

    (fp-double-zero (values 0 t))

    (double-reg (values (tn-offset tn) t))))

    (double-reg (values (tn-offset tn) t))

    (complex-single-reg (values (tn-offset tn) nil))

    (complex-double-reg (values (tn-offset tn) t))))



(defconstant-eqx compare-conditions

  '(:never := :< :<= :<< :<<= :sv :od :tr :<> :>= :> :>>= :>> :nsv :ev)

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.36"
 
"1.0.24.37"