Changeset 14942

Timestamp:

Aug 16, 2011, 10:33:30 PM (13 years ago)

Author:

Gary Byers

Message:

%FIXNUM-{REF|SET}-DOUBLE-FLOAT support in PPC backends.

Location:

trunk/source/compiler/PPC

Files:

• PPC32/ppc32-vinsns.lisp (modified) (1 diff)
• PPC64/ppc64-vinsns.lisp (modified) (1 diff)
• ppc2.lisp (modified) (1 diff)

trunk/source/compiler/PPC/PPC32/ppc32-vinsns.lisp

@@ -4042 +4042 @@
   (fneg dest src))
 
+(define-ppc32-vinsn fixnum-ref-c-double-float (((dest :double-float))
+                                               ((base :imm)
+                                                (idx :u16const)))
+  (lfd dest (:apply ash idx 3) base))
+
+(define-ppc32-vinsn fixnum-ref-double-float (((dest :double-float))
+                                               ((base :imm)
+                                                (idx :imm))
+                                               ((temp :imm)))
+  (add temp idx idx)
+  (lfdx dest base temp))
+
+
+(define-ppc32-vinsn fixnum-set-c-double-float (()
+                                               ((base :imm)
+                                                (idx :u16const)
+                                                (val :double-float)))
+  (stfd val (:apply ash idx 3) base))
+
+(define-ppc32-vinsn fixnum-set-c-double-float (()
+                                               ((base :imm)
+                                                (idx :imm)
+                                                (val :double-float))
+                                               ((temp :imm)))
+  (add temp idx idx)
+  (stfdx val base temp))
+
 ;;; In case ppc32::*ppc-opcodes* was changed since this file was compiled.
 (queue-fixup

trunk/source/compiler/PPC/PPC64/ppc64-vinsns.lisp

@@ -4033 +4033 @@
 (define-ppc64-vinsn single-float-negate (((dest :single-float))
                                          ((src :single-float)))
-  (fneg dest src))
+ (fneg dest src))
+(define-ppc64-vinsn fixnum-ref-c-double-float (((dest :double-float))
+                                               ((base :imm)
+                                                (idx :u16const)))
+  (lfd dest (:apply ash idx 3) base))
+
+(define-ppc64-vinsn fixnum-ref-double-float (((dest :double-float))
+                                             ((base :imm)
+                                              (idx :imm)))
+  (lfdx dest base idx))
+
+
+(define-ppc64-vinsn fixnum-set-c-double-float (()
+                                               ((base :imm)
+                                                (idx :u16const)
+                                                (val :double-float)))
+  (stfd val (:apply ash idx 3) base))
+
+(define-ppc64-vinsn fixnum-set-c-double-float (()
+                                               ((base :imm)
+                                                (idx :imm)
+                                                (val :double-float)))
+  (stfdx val base idx))
 
 ;;; In case ppc64::*ppc-opcodes* was changed since this file was compiled.

trunk/source/compiler/PPC/ppc2.lisp

@@ -9243 +9243 @@
                 nil))
 
+(defppc2 ppc2-fixnum-ref-double-float %fixnum-ref-double-float (seg vreg xfer base index)
+  (if (null vreg)
+    (progn
+      (ppc2-form base seg nil nil)
+      (ppc2-form index seg nil xfer))
+    (let* ((fix (acode-fixnum-form-p index)))
+      (unless (typep fix '(unsigned-byte 12))
+        (setq fix nil))
+      (if (and (= (hard-regspec-class vreg) hard-reg-class-fpr)
+               (= (get-regspec-mode vreg) hard-reg-class-fpr-mode-double) )
+        (cond (fix
+               (! fixnum-ref-c-double-float vreg (ppc2-one-untargeted-reg-form seg base ppc::arg_z) fix))
+              (t
+               (multiple-value-bind (rbase rindex) (ppc2-two-untargeted-reg-forms seg base ppc::arg_y index ppc::arg_z)
+                 (! fixnum-ref-double-float vreg rbase rindex))))
+        (with-fp-target () (target :double-float)
+          (cond (fix
+                 (! fixnum-ref-c-double-float target (ppc2-one-untargeted-reg-form seg base ppc::arg_z) fix))
+                (t
+                 (multiple-value-bind (rbase rindex) (ppc2-two-untargeted-reg-forms seg base ppc::arg_y index ppc::arg_z)
+                   (! fixnum-ref-double-float target rbase rindex))))
+          (<- target)))
+      (^))))
+
+(defppc2 ppc2-fixnum-set-double-float %fixnum-set-double-float (seg vreg xfer base index val)
+  (let* ((fix (acode-fixnum-form-p index)))
+    (unless (typep fix '(unsigned-byte 12))
+      (setq fix nil))
+    (cond ((or (null vreg)
+               (and (= (hard-regspec-class vreg) hard-reg-class-fpr)
+                    (= (get-regspec-mode vreg) hard-reg-class-fpr-mode-double)))
+           (let* ((fhint (or vreg ($ ppc::fp1 :class :fpr :mode :double-float))))
+             (if fix
+               (multiple-value-bind (rbase rval)
+                   (ppc2-two-untargeted-reg-forms seg base ($ ppc::arg_z) val fhint)
+                 (! fixnum-set-c-double-float rbase fix rval)
+                 (<- rval))
+               (multiple-value-bind (rbase rindex rval)
+                   (ppc2-three-untargeted-reg-forms seg base ($ ppc::arg_y) index ($ ppc::arg_z) val fhint)
+                 (! fixnum-set-double-float rbase rindex rval)
+                 (<- rval)))))
+          (t
+           (if fix
+             (multiple-value-bind (rbase rboxed)
+                 (ppc2-two-untargeted-reg-forms seg base ($ ppc::arg_y) val ($ ppc::arg_z))
+               (with-fp-target () (rval :double-float)
+                 (ppc2-copy-register seg rval rboxed)
+                 (! fixnum-set-c-double-float rbase fix rval))
+               (<- rboxed))
+             (multiple-value-bind (rbase rindex rboxed)
+                 (ppc2-three-untargeted-reg-forms seg base ($ ppc::arg_x) index ($ ppc::arg_y) val ($ ppc::arg_z))
+               (with-fp-target () (rval :double-float)
+                 (ppc2-copy-register seg rval rboxed)
+                 (! fixnum-set-double-float rbase rindex rval))
+               (<- rboxed)))))
+    (^)))