[Openmcl-cvs-notifications] r16264 - in /trunk/source: compiler/ARM/arm-vinsns.lisp compiler/ARM/arm2.lisp compiler/acode-rewrite.lisp lib/armenv.lisp

gb at clozure.com gb at clozure.com
Sat Sep 27 22:46:44 UTC 2014


Author: gb
Date: Sat Sep 27 22:46:44 2014
New Revision: 16264

Log:
More fp temps on ARM (thru s28/d14/q7).
Recognize that registers of type :COMPLEX-DOUBLE-FLOAT are quadwords, use
arm-quad-to-double to access the most significant doubleword.
Implement simple arithmetic (+.-,*) on complex floats on ARM, enable it.

Modified:
    trunk/source/compiler/ARM/arm-vinsns.lisp
    trunk/source/compiler/ARM/arm2.lisp
    trunk/source/compiler/acode-rewrite.lisp
    trunk/source/lib/armenv.lisp

Modified: trunk/source/compiler/ARM/arm-vinsns.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/ARM/arm-vinsns.lisp	(original)
+++ trunk/source/compiler/ARM/arm-vinsns.lisp	Sat Sep 27 22:46:44 2014
@@ -28,6 +28,8 @@
 (defmacro define-arm-vinsn (vinsn-name (results args &optional temps) &bod=
y body)
   (%define-vinsn *arm-backend* vinsn-name results args temps body))
 =

+(defun arm-quad-to-double (q)
+  (* 2 (%hard-regspec-value q)))
 =

 ;;; Non-volatile FPRs.
 (define-arm-vinsn (push-nvfprs :push :multiple :doubleword :csp :predicata=
ble)
@@ -206,7 +208,7 @@
       (unscaled-idx :imm)))
   (add arm::lr v (:$ arm::misc-dfloat-offset))
   (add arm::lr arm::lr (:lsl unscaled-idx (:$ 2)))
-  (fldmiad dest arm::lr   2)
+  (fldmiad (:apply arm-quad-to-double dest) arm::lr   2)
   (mov lr (:$ 0)))
 =

 (define-arm-vinsn (misc-ref-c-double-float :predicatable :sets-lr)
@@ -242,7 +244,7 @@
       (unscaled-idx :imm)))             ; a fixnum
   (add lr v (:$ arm::misc-dfloat-offset))
   (add lr lr (:lsl unscaled-idx (:$ 2)))
-  (fstmiad val lr 2)
+  (fstmiad (:apply arm-quad-to-double val) lr 2)
   (mov lr (:$ 0)))
 =

 (define-arm-vinsn (misc-set-c-single-float :predicatable)
@@ -1683,7 +1685,73 @@
   (fnegd dest src))
 =

 =

-
+(define-arm-vinsn (complex-double-float+-2 :predicatable) (((result :compl=
ex-double-float))
+                                                          ((x :complex-dou=
ble-float)
+                                                           (y :complex-dou=
ble-float)))
+  (faddd (:apply arm-quad-to-double result) (:apply arm-quad-to-double x) =
(:apply arm-quad-to-double y))
+  (faddd (:apply 1+ (:apply arm-quad-to-double result))
+         (:apply 1+ (:apply arm-quad-to-double  x))
+         (:apply 1+ (:apply arm-quad-to-double y))))
+
+
+(define-arm-vinsn (complex-double-float--2 :predicatable) (((result :compl=
ex-double-float))
+                                                          ((x :complex-dou=
ble-float)
+                                                           (y :complex-dou=
ble-float)))
+  (fsubd (:apply arm-quad-to-double result) (:apply arm-quad-to-double x) =
(:apply arm-quad-to-double y))
+  (fsubd (:apply 1+ (:apply arm-quad-to-double result))
+         (:apply 1+ (:apply arm-quad-to-double  x))
+         (:apply 1+ (:apply arm-quad-to-double  y))))
+
+(define-arm-vinsn (complex-double-float*-2 :predicatable) (((result :compl=
ex-double-float))
+                                                          ((x :complex-dou=
ble-float)
+                                                           (y :complex-dou=
ble-float))
+                                                           ((t0 :double-fl=
oat)
+                                                            (t1 :double-fl=
oat)))
+  (fmuld t0 (:apply arm-quad-to-double x) (:apply arm-quad-to-double y))
+  (fmuld t1 (:apply 1+ (:apply arm-quad-to-double x)) (:apply 1+ (:apply a=
rm-quad-to-double y)))
+  (fsubd (:apply arm-quad-to-double result) t0 t1)
+  (fmuld t0 (:apply arm-quad-to-double x) (:apply 1+ (:apply arm-quad-to-d=
ouble y)))
+  (fmuld t1 (:apply arm-quad-to-double y) (:apply 1+ (:apply arm-quad-to-d=
ouble x)))
+  (faddd (:apply 1+ (:apply arm-quad-to-double result)) t0 t1))
+         =

+                                                           =

+
+(define-arm-vinsn (complex-single-float*-2 :predicatable) (((result :compl=
ex-single-float))
+                                                          ((x :complex-sin=
gle-float)
+                                                           (y :complex-sin=
gle-float))
+                                                           ((t0 :single-fl=
oat)
+                                                            (t1 :single-fl=
oat)))
+  (fmuls t0 (:apply * 2 (:apply %hard-regspec-value x)) (:apply * 2 (:appl=
y %hard-regspec-value  y)))
+  (fmuls t1 (:apply 1+ (:apply * 2 (:apply %hard-regspec-value x)))  (:app=
ly 1+ (:apply * 2 (:apply %hard-regspec-value y))))
+  (fsubs (:apply * 2 (:apply %hard-regspec-value result)) t0 t1)
+  (fmuls t0 (:apply * 2 (:apply %hard-regspec-value x)) (:apply 1+ (:apply=
 * 2 (:apply %hard-regspec-value y))))
+  (fmuls t1 (:apply * 2 (:apply %hard-regspec-value y)) (:apply 1+ (:apply=
 * 2 (:apply %hard-regspec-value x))))
+  (fadds (:apply 1+ (:apply * 2 (:apply %hard-regspec-value result))) t0 t=
1))
+
+
+(define-arm-vinsn (complex-single-float+-2 :predicatable) (((result :compl=
ex-single-float))
+                                                          ((x :complex-sin=
gle-float)
+                                                           (y :complex-sin=
gle-float)))
+  (fadds (:apply * 2 (:apply %hard-regspec-value result))
+          (:apply * 2 (:apply %hard-regspec-value x))
+          (:apply * 2 (:apply %hard-regspec-value y)))
+  (fadds (:apply 1+ (:apply * 2 (:apply %hard-regspec-value result)))
+         (:apply 1+ (:apply * 2 (:apply %hard-regspec-value x)))
+         (:apply 1+ (:apply * 2 (:apply %hard-regspec-value y)))))
+
+(define-arm-vinsn (complex-single-float--2 :predicatable) (((result :compl=
ex-single-float))
+                                                          ((x :complex-sin=
gle-float)
+                                                           (y :complex-sin=
gle-float)))
+  (fsubs (:apply * 2 (:apply %hard-regspec-value result))
+          (:apply * 2 (:apply %hard-regspec-value x))
+          (:apply * 2 (:apply %hard-regspec-value y)))
+  (fsubs (:apply 1+ (:apply * 2 (:apply %hard-regspec-value result)))
+         (:apply 1+ (:apply * 2 (:apply %hard-regspec-value x)))
+         (:apply 1+ (:apply * 2 (:apply %hard-regspec-value y)))))
+
+
+  =

+  =

 (define-arm-vinsn single-float-compare (((crf :crf))
                                         ((arg0 :single-float)
                                          (arg1 :single-float))
@@ -1941,9 +2009,10 @@
   ((:not (:pred =3D
                 (:apply %hard-regspec-value dest)
                 (:apply %hard-regspec-value src)))
-   (fcpyd dest src)
-   (fcpyd (:apply 1+ (:apply %hard-regspec-value dest))
-          (:apply 1+ (:apply %hard-regspec-value src)))))
+   (fcpyd (:apply arm-quad-to-double dest)
+          (:apply arm-quad-to-double src))
+   (fcpyd (:apply 1+ (:apply arm-quad-to-double dest))
+          (:apply 1+ (:apply arm-quad-to-double  src)))))
 =

 (define-arm-vinsn (vcell-ref :predicatable)
     (((dest :lisp))
@@ -2599,7 +2668,7 @@
   (mov result allocptr)
   (bic allocptr allocptr (:$ arm::fulltagmask))
   (add lr result (:$ arm::complex-double-float.realpart))
-  (fstmiad fpreg lr 2)
+  (fstmiad (:apply arm-quad-to-double fpreg) lr 2)
   (mov lr (:$ 0)))
 =

 =

@@ -2674,7 +2743,7 @@
     (((target :complex-double-float))
      ((source :lisp)))
   (add lr source (:$ arm::complex-double-float.realpart))
-  (fldmiad target lr 2)
+  (fldmiad (:apply arm-quad-to-double target) lr 2)
   (mov lr (:$ 0)))
 =

 ;;; Extract a double-float value, typechecking in the process.
@@ -3361,8 +3430,8 @@
     (()
      ((val :complex-double-float)
       (offset :u16const)))
-  (fstd val (:@ sp (:$ (:apply + 8 offset))))
-  (fstd (:apply 1+ (:apply %hard-regspec-value val))
+  (fstd (:apply arm-quad-to-double val) (:@ sp (:$ (:apply + 8 offset))))
+  (fstd (:apply 1+ (:apply arm-quad-to-double val))
         (:@ sp (:$ (:apply + 8 8 offset)))))
 =

 (define-arm-vinsn (nfp-store-complex-double-float-nested :nfp :set :double=
word)
@@ -3370,24 +3439,24 @@
      ((val :complex-double-float)
       (offset :u16const)))
   (ldr lr (:@ rcontext (:$ arm::tcr.nfp)))
-  (fstd val (:@ lr (:$ (:apply + 8 offset))))
-  (fstd (:apply 1+ (:apply %hard-regspec-value val))
+  (fstd (:apply arm-quad-to-double val) (:@ lr (:$ (:apply + 8 offset))))
+  (fstd (:apply 1+ (:apply arm-quad-to-double val))
         (:@ lr (:$ (:apply + 8 8 offset)))))
   =

 =

 (define-arm-vinsn (nfp-load-complex-double-float :nfp :ref :doubleword)
     (((val :complex-double-float))
      ((offset :u16const)))
-  (fldd val (:@ sp (:$ (:apply + 8 offset))))
-  (fldd (:apply 1+ (:apply %hard-regspec-value val))
+  (fldd (:apply arm-quad-to-double val) (:@ sp (:$ (:apply + 8 offset))))
+  (fldd (:apply 1+ (:apply arm-quad-to-double val))
         (:@ sp (:$ (:apply + 8 8 offset)))))
 =

 (define-arm-vinsn (nfp-load-complex-double-float-nested :nfp :ref :doublew=
ord)
     (((val :complex-double-float))
      ((offset :u16const)))
   (ldr lr (:@ rcontext (:$ arm::tcr.nfp)))
-  (fldd val (:@ lr (:$ (:apply + 8 offset))))
-  (fldd (:apply 1+ (:apply %hard-regspec-value val))
+  (fldd (:apply arm-quad-to-double val) (:@ lr (:$ (:apply + 8 offset))))
+  (fldd (:apply 1+ (:apply arm-quad-to-double val))
         (:@ lr (:$ (:apply + 8 8 offset)))))
 =

 (define-arm-vinsn (nfp-store-single-float :nfp :set) (()
@@ -4358,11 +4427,11 @@
 =

 (define-arm-vinsn %complex-double-float-realpart  (((dest :double-float))
                                                    ((src :complex-double-f=
loat)))
-  (fcpyd dest src))
+  (fcpyd dest (:apply arm-quad-to-double src)))
 =

 (define-arm-vinsn %complex-double-float-imagpart  (((dest :double-float))
                                                    ((src :complex-double-f=
loat)))
-  (fcpyd dest (:apply 1+ (:apply %hard-regspec-value src))))
+  (fcpyd dest (:apply 1+ (:apply arm-quad-to-double src))))
 =

   =

 =


Modified: trunk/source/compiler/ARM/arm2.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/ARM/arm2.lisp	(original)
+++ trunk/source/compiler/ARM/arm2.lisp	Sat Sep 27 22:46:44 2014
@@ -7702,6 +7702,96 @@
 (defarm2-sf-op arm2-%short-float*-2 %short-float*-2 single-float*-2)
 (defarm2-sf-op arm2-%short-float/-2 %short-float/-2 single-float/-2)
 =

+(defarm2 arm2-%complex-double-float+-2  %complex-double-float+-2 (seg vreg=
 xfer x y)
+  (let* ((*available-backend-fp-temps* *available-backend-fp-temps*)
+         (target (if (and vreg (eql (hard-regspec-class vreg) hard-reg-cla=
ss-fpr)
+                          (eql (get-regspec-mode vreg) hard-reg-class-fpr-=
mode-complex-double-float))
+                   vreg
+                   (available-fp-temp  *available-backend-fp-temps* :compl=
ex-double-float))))
+    (with-fp-target () (r1 :complex-double-float)
+      (with-fp-target (r1) (r2 :complex-double-float)
+        (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg x =
r1 y r2)
+          (! complex-double-float+-2 target r1 r2)
+          (unless (eq target vreg)
+            (ensuring-node-target (node vreg)
+              (arm2-copy-register seg node target))))))
+    (^)))
+
+(defarm2 arm2-%complex-double-float--2  %complex-double-float--2 (seg vreg=
 xfer x y)
+  (let* ((*available-backend-fp-temps* *available-backend-fp-temps*)
+         (target (if (and vreg (eql (hard-regspec-class vreg) hard-reg-cla=
ss-fpr)
+                          (eql (get-regspec-mode vreg) hard-reg-class-fpr-=
mode-complex-double-float))
+                   vreg
+                   (available-fp-temp  *available-backend-fp-temps* :compl=
ex-double-float))))
+    (with-fp-target () (r1 :complex-double-float)
+      (with-fp-target (r1 target) (r2 :complex-double-float)
+        (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg x =
r1 y r2)
+          (! complex-double-float--2 target r1 r2)
+          (unless (eq target vreg)
+            (ensuring-node-target (node vreg)
+              (arm2-copy-register seg node target))))))
+    (^)))
+
+(defarm2 arm2-%complex-double-float*-2  %complex-double-float*-2 (seg vreg=
 xfer x y)
+  (let* ((*available-backend-fp-temps* *available-backend-fp-temps*)
+         (target (if (and vreg (eql (hard-regspec-class vreg) hard-reg-cla=
ss-fpr)
+                          (eql (get-regspec-mode vreg) hard-reg-class-fpr-=
mode-complex-double-float))
+                   vreg
+                   (available-fp-temp  *available-backend-fp-temps* :compl=
ex-double-float))))
+    (with-fp-target (target) (r1 :complex-double-float)
+      (with-fp-target (r1 target) (r2 :complex-double-float)
+        (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg x =
r1 y r2)
+          (! complex-double-float*-2 target r1 r2)
+          (unless (eq target vreg)
+            (ensuring-node-target (node vreg)
+              (arm2-copy-register seg node target))))))
+    (^)))
+
+(defarm2 arm2-%complex-single-float+-2  %complex-single-float+-2 (seg vreg=
 xfer x y)
+  (let* ((*available-backend-fp-temps* *available-backend-fp-temps*)
+         (target (if (and vreg (eql (hard-regspec-class vreg) hard-reg-cla=
ss-fpr)
+                          (eql (get-regspec-mode vreg) hard-reg-class-fpr-=
mode-complex-single-float))
+                   vreg
+                   (available-fp-temp  *available-backend-fp-temps* :compl=
ex-single-float))))
+    (with-fp-target () (r1 :complex-single-float)
+      (with-fp-target (r1) (r2 :complex-single-float)
+        (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg x =
r1 y r2)
+          (! complex-single-float+-2 target r1 r2)
+          (unless (eq target vreg)
+            (ensuring-node-target (node vreg)
+              (arm2-copy-register seg node target))))))
+    (^)))
+
+(defarm2 arm2-%complex-single-float--2  %complex-single-float--2 (seg vreg=
 xfer x y)
+  (let* ((*available-backend-fp-temps* *available-backend-fp-temps*)
+         (target (if (and vreg (eql (hard-regspec-class vreg) hard-reg-cla=
ss-fpr)
+                          (eql (get-regspec-mode vreg) hard-reg-class-fpr-=
mode-complex-single-float))
+                   vreg
+                   (available-fp-temp  *available-backend-fp-temps* :compl=
ex-single-float))))
+    (with-fp-target () (r1 :complex-single-float)
+      (with-fp-target (r1) (r2 :complex-single-float)
+        (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg x =
r1 y r2)
+          (! complex-single-float--2 target r1 r2)
+          (unless (eq target vreg)
+            (ensuring-node-target (node vreg)
+              (arm2-copy-register seg node target))))))
+    (^)))
+
+(defarm2 arm2-%complex-single-float*-2  %complex-single-float*-2 (seg vreg=
 xfer x y)
+  (let* ((*available-backend-fp-temps* *available-backend-fp-temps*)
+         (target (if (and vreg (eql (hard-regspec-class vreg) hard-reg-cla=
ss-fpr)
+                          (eql (get-regspec-mode vreg) hard-reg-class-fpr-=
mode-complex-single-float))
+                   vreg
+                   (available-fp-temp  *available-backend-fp-temps* :compl=
ex-single-float))))
+    (with-fp-target (target) (r1 :complex-single-float)
+      (with-fp-target (r1 target) (r2 :complex-single-float)
+        (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg x =
r1 y r2)
+          (! complex-single-float*-2 target r1 r2)
+          (unless (eq target vreg)
+            (ensuring-node-target (node vreg)
+              (arm2-copy-register seg node target))))))
+    (^)))
+
 (defun arm2-get-float (seg vreg xfer ptr offset double-p fp-reg)
   (with-arm-local-vinsn-macros (seg vreg xfer)
     (cond ((null vreg)

Modified: trunk/source/compiler/acode-rewrite.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/acode-rewrite.lisp	(original)
+++ trunk/source/compiler/acode-rewrite.lisp	Sat Sep 27 22:46:44 2014
@@ -219,12 +219,12 @@
                                   (subtypep t2 'single-float))
                              (setq newtype 'single-float)
                              (%nx1-operator %short-float+-2))
-                            ((and (target-arch-case ((:x8664 :x8632) t))
+                            ((and (target-arch-case ((:x8664 :x8632 :arm) =
t))
                                   (subtypep t1 '(complex double-float))
                                   (subtypep t2 '(complex double-float)))
                              (setq newtype '(complex double-float))
                              (%nx1-operator %complex-double-float+-2))
-                            ((and (target-arch-case ((:x8664 :x8632) t))
+                            ((and (target-arch-case ((:x8664 :x8632 :arm) =
t))
                                   (subtypep t1 '(complex single-float))
                                   (subtypep t2 '(complex single-float)))
                              (setq newtype '(complex single-float))
@@ -265,12 +265,12 @@
                                   (subtypep t2 'single-float))
                              (setq newtype 'single-float)
                              (%nx1-operator %short-float--2))
-                            ((and (target-arch-case ((:x8664 :x8632) t))
+                            ((and (target-arch-case ((:x8664 :x8632 :arm) =
t))
                                   (subtypep t1 '(complex double-float))
                                   (subtypep t2 '(complex double-float)))
                              (setq newtype '(complex double-float))
                              (%nx1-operator %complex-double-float--2))
-                            ((and (target-arch-case ((:x8664 :x8632) t))
+                            ((and (target-arch-case ((:x8664 :x8632 :arm) =
t))
                                   (subtypep t1 '(complex single-float))
                                   (subtypep t2 '(complex single-float)))
                              (setq newtype '(complex single-float))
@@ -337,12 +337,12 @@
                                            (subtypep t2 'single-float))
                                       (setq newtype 'single-float)
                                       (%nx1-operator %short-float*-2))
-                                     ((and (target-arch-case ((:x8664 :x86=
32) t))
+                                     ((and (target-arch-case ((:x8664 :x86=
32 :arm) t))
                                            (subtypep t1 '(complex double-f=
loat))
                                            (subtypep t2 '(complex double-f=
loat)))
                                       (setq newtype '(complex double-float=
))
                                       (%nx1-operator %complex-double-float=
*-2))
-                                     ((and (target-arch-case ((:x8664 :x86=
32) t))
+                                     ((and (target-arch-case ((:x8664 :x86=
32 :arm ) t))
                                            (subtypep t1 '(complex single-f=
loat))
                                            (subtypep t2 '(complex single-f=
loat)))
                                       (setq newtype '(complex single-float=
))

Modified: trunk/source/lib/armenv.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/armenv.lisp	(original)
+++ trunk/source/lib/armenv.lisp	Sat Sep 27 22:46:44 2014
@@ -60,7 +60,7 @@
                             arm::imm1
                             arm::imm2))
 =

-(defconstant arm-temp-fp-regs (1- (ash 1 14)))
+(defconstant arm-temp-fp-regs (1- (ash 1 28)))
 =

 (defconstant arm-cr-fields (make-mask 0))
 =




More information about the Openmcl-cvs-notifications mailing list