Changeset 14940

Timestamp:

Aug 16, 2011, 1:43:43 PM (13 years ago)

Author:

Gary Byers

Message:

In things defined by DEFARM2-SF-OP and DEFARM2-DF-OP, try to ensure that
the result register is disjoint from operands when generating "safe" code,
so that operands can be reported more reliably in case of an exception.

Define %FIXNUM-REF-DOUBLE-FLOAT and %FIXNUM-SET-DOUBLE-FLOAT in the front
end; implement the in the ARM backend (so far.)

Location:

trunk/source/compiler

Files:

• ARM/arm-vinsns.lisp (modified) (1 diff)
• ARM/arm2.lisp (modified) (4 diffs)
• nx1.lisp (modified) (1 diff)
• nxenv.lisp (modified) (1 diff)

trunk/source/compiler/ARM/arm-vinsns.lisp

@@ -4004 +4004 @@
   (mvn dest temp))
 
+(define-arm-vinsn fixnum-ref-c-double-float (((dest :double-float))
+                                             ((base :imm)
+                                              (idx :u32const)))
+  (fldd dest (:@ base (:$ (:apply ash idx 3)))))
+
+(define-arm-vinsn fixnum-ref-double-float (((dest :double-float))
+                                           ((base :imm)
+                                            (idx :imm))
+                                           ((temp :imm)))
+  (add temp base (:lsl idx (:$ 1)))
+  (fldd dest (:@ temp (:$ 0))))
+
+(define-arm-vinsn fixnum-set-c-double-float (()
+                                             ((base :imm)
+                                              (idx :u32const)
+                                              (val :double-float)))
+  (fstd val (:@ base (:$ (:apply ash idx 3)))))
+
+
+(define-arm-vinsn fixnum-set-double-float (()
+                                           ((base :imm)
+                                            (idx :imm)
+                                            (val :double-float))
+                                           ((temp :imm)))
+  (add temp base (:lsl idx (:$ 1)))
+  (fstd val (:@ temp (:$ 0))))
+                                             
+
 ;;; In case arm::*arm-opcodes* was changed since this file was compiled.
 #+maybe-never

trunk/source/compiler/ARM/arm2.lisp

@@ -6200 +6200 @@
     (arm2-form seg vreg xfer (if (nx-null test-val) false true))
     (multiple-value-bind (ranges trueforms var otherwise)
-        #+notyet (nx2-reconstruct-case testform true false)
-        #-notyet (values nil nil nil nil)
+        (nx2-reconstruct-case testform true false)
       (or (arm2-generate-casejump seg vreg xfer ranges trueforms var otherwise)
           (let* ((cstack *arm2-cstack*)
@@ -6934 +6933 @@
                (if (= (hard-regspec-class vreg) hard-reg-class-fpr)
                  (if *arm2-float-safety*
-                     (! ,safe-vinsn vreg r1 r2)
-                     (! ,vinsn vreg r1 r2))
+                   (with-fp-target (r1 r2) (result :double-float)
+                     (! ,safe-vinsn result r1 r2)
+                     (<- result))
+                   (! ,vinsn vreg r1 r2))
                  (with-fp-target (r1 r2) (result :double-float)
                    (if *arm2-float-safety*
@@ -6955 +6956 @@
                (if (= (hard-regspec-class vreg) hard-reg-class-fpr)
                  (if *arm2-float-safety*
-                   (! ,safe-vinsn vreg r1 r2)
+                   (with-fp-target (r1 r2) (result :single-float)
+                     (! ,safe-vinsn result r1 r2)
+                     (<- result))
                    (! ,vinsn vreg r1 r2))
                  (with-fp-target (r1 r2) (result :single-float)
@@ -8837 +8840 @@
         (arm2-two-targeted-reg-forms seg num ($ arm::arg_y) amt ($ arm::arg_z))
         (arm2-fixed-call-builtin seg vreg xfer '.SPbuiltin-ash))))
+
+(defarm2 arm2-fixnum-ref-double-float %fixnum-ref-double-float (seg vreg xfer base index)
+  (if (null vreg)
+    (progn
+      (arm2-form base seg nil nil)
+      (arm2-form index seg nil xfer))
+    (let* ((fix (acode-fixnum-form-p index)))
+      (unless (typep fix '(integer 0 (128)))
+        (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 (arm2-one-untargeted-reg-form seg base arm::arg_z) fix))
+              (t
+               (multiple-value-bind (rbase rindex) (arm2-two-untargeted-reg-forms seg base arm::arg_y index arm::arg_z)
+                 (! fixnum-ref-double-float vreg rbase rindex))))
+        (with-fp-target () (target :double-float)
+        (cond (fix
+               (! fixnum-ref-c-double-float target (arm2-one-untargeted-reg-form seg base arm::arg_z) fix))
+              (t
+               (multiple-value-bind (rbase rindex) (arm2-two-untargeted-reg-forms seg base arm::arg_y index arm::arg_z)
+                 (! fixnum-ref-double-float target rbase rindex))))
+        (<- target)))
+      (^))))
+
+(defarm2 arm2-fixnum-set-double-float %fixnum-set-double-float (seg vreg xfer base index val)
+  (let* ((fix (acode-fixnum-form-p index)))
+    (unless (typep fix '(integer 0 (128)))
+      (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 ($ arm::d0 :class :fpr :mode :double-float))))
+             (if fix
+               (multiple-value-bind (rbase rval)
+                   (arm2-two-untargeted-reg-forms seg base ($ arm::arg_z) val fhint)
+                 (! fixnum-set-c-double-float rbase fix rval)
+                 (<- rval))
+               (multiple-value-bind (rbase rindex rval)
+                   (arm2-three-untargeted-reg-forms seg base ($ arm::arg_y) index ($ arm::arg_z) val fhint)
+                 (! fixnum-set-double-float rbase rindex rval)
+                 (<- rval)))))
+          (t
+           (if fix
+             (multiple-value-bind (rbase rboxed)
+                 (arm2-two-untargeted-reg-forms seg base ($ arm::arg_y) val ($ arm::arg_z))
+               (with-fp-target () (rval :double-float)
+                 (arm2-copy-register seg rval rboxed)
+                 (! fixnum-set-c-double-float rbase fix rval))
+               (<- rboxed))
+             (multiple-value-bind (rbase rindex rboxed)
+                 (arm2-three-untargeted-reg-forms seg base ($ arm::arg_x) index ($ arm::arg_y) val ($ arm::arg_z))
+               (with-fp-target () (rval :double-float)
+                 (arm2-copy-register seg rval rboxed)
+                 (! fixnum-set-double-float rbase rindex rval))
+               (<- rboxed)))))
+    (^)))

trunk/source/compiler/nx1.lisp

@@ -222 +222 @@
               (nx1-form base)
               (nx1-form offset)))
+
+(defnx1 nx1-fixnum-ref-double-float ((%fixnum-ref-double-float)) (base &optional (index 0))
+  (make-acode (%nx1-operator typed-form)
+               'double-float
+               (make-acode (%nx1-operator %fixnum-ref-double-float)
+                           (nx1-form base)
+                           (nx1-form index))))
+
+(defnx1 nx2-fixnum-set-double-float ((%fixnum-set-double-float)) (base index-or-val &optional (val nil val-p))
+  (unless val-p
+    (setq val index-or-val index-or-val 0))
+  (make-acode (%nx1-operator typed-form)
+               'double-float
+               (make-acode (%nx1-operator %fixnum-set-double-float)
+                           (nx1-form base)
+                           (nx1-form index-or-val)
+                           (nx1-form val))))
+               
 
 (defnx1 nx1-type-unaryop ((typecode) (lisptag) (fulltag))

trunk/source/compiler/nxenv.lisp

@@ -207 +207 @@
      (%badarg1 . 0)
      (%badarg2 . 0)
-     (newblocktag . 0)
-     (newgotag . 0)
+     (%fixnum-ref-double-float . #.(logior operator-acode-subforms-mask  operator-single-valued-mask))
+     (%fixnum-set-double-float . #.(logior operator-acode-subforms-mask  operator-single-valued-mask))
      (flet . 0)                         ; may not be necessary - for dynamic-extent, mostly
                                         ; for dynamic-extent, forward refs, etc.