1.0.24.37: full raw-instance-slot support on HPPA

 * Patch by Larry Valkama.

diff --git a/src/compiler/hppa/cell.lisp b/src/compiler/hppa/cell.lisp
index 070da3b..a58ae4e 100644 (file)
--- a/src/compiler/hppa/cell.lisp
+++ b/src/compiler/hppa/cell.lisp
@@ -257,15 +257,28 @@
 
 \f
 ;;;; 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)
-                               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))))
+    (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)))
+      (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)
-                                 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))
-
+    (let ((value-real  (complex-double-reg-real-tn value))
+          (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)))
+      (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)))))

diff --git a/src/compiler/hppa/float.lisp b/src/compiler/hppa/float.lisp
index 121fb5e..649c922 100644 (file)
--- a/src/compiler/hppa/float.lisp
+++ b/src/compiler/hppa/float.lisp
@@ -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

diff --git a/src/compiler/hppa/insts.lisp b/src/compiler/hppa/insts.lisp
index a1f6d24..fc31a65 100644 (file)
--- a/src/compiler/hppa/insts.lisp
+++ b/src/compiler/hppa/insts.lisp
@@ -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)

diff --git a/version.lisp-expr b/version.lisp-expr
index a0a5aa8..ba0cdd9 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.36"
+"1.0.24.37"