[Openmcl-cvs-notifications] r14940 - in /trunk/source/compiler: ARM/arm-vinsns.lisp ARM/arm2.lisp nx1.lisp nxenv.lisp
gb at clozure.com
gb at clozure.com
Tue Aug 16 15:43:43 CDT 2011
Author: gb
Date: Tue Aug 16 15:43:43 2011
New Revision: 14940
Log:
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.)
Modified:
trunk/source/compiler/ARM/arm-vinsns.lisp
trunk/source/compiler/ARM/arm2.lisp
trunk/source/compiler/nx1.lisp
trunk/source/compiler/nxenv.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 Tue Aug 16 15:43:43 2011
@@ -4003,6 +4003,34 @@
(orr temp src (:$ arm::fixnummask))
(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
(queue-fixup
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 Tue Aug 16 15:43:43 2011
@@ -6199,8 +6199,7 @@
(if (setq test-val (nx2-constant-form-value (acode-unwrapped-form-value =
testform)))
(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 other=
wise)
(let* ((cstack *arm2-cstack*)
(vstack *arm2-vstack*)
@@ -6933,8 +6932,10 @@
(multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms s=
eg f0 r1 f1 r2)
(if (=3D (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*
(! ,safe-vinsn result r1 r2)
@@ -6954,7 +6955,9 @@
(multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms s=
eg f0 r1 f1 r2)
(if (=3D (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)
(if *arm2-float-safety*
@@ -8835,4 +8838,61 @@
(or (acode-optimize-ash seg vreg xfer num amt *arm2-trust-declarations*)
(progn
(arm2-two-targeted-reg-forms seg num ($ arm::arg_y) amt ($ arm::ar=
g_z))
- (arm2-fixed-call-builtin seg vreg xfer '.SPbuiltin-ash))))
+ (arm2-fixed-call-builtin seg vreg xfer '.SPbuiltin-ash))))
+
+(defarm2 arm2-fixnum-ref-double-float %fixnum-ref-double-float (seg vreg x=
fer 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 (=3D (hard-regspec-class vreg) hard-reg-class-fpr)
+ (=3D (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-re=
g-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-re=
g-form seg base arm::arg_z) fix))
+ (t
+ (multiple-value-bind (rbase rindex) (arm2-two-untargeted-re=
g-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 x=
fer base index val)
+ (let* ((fix (acode-fixnum-form-p index)))
+ (unless (typep fix '(integer 0 (128)))
+ (setq fix nil))
+ (cond ((or (null vreg)
+ (and (=3D (hard-regspec-class vreg) hard-reg-class-fpr)
+ (=3D (get-regspec-mode vreg) hard-reg-class-fpr-mode-d=
ouble)))
+ (let* ((fhint (or vreg ($ arm::d0 :class :fpr :mode :double-flo=
at))))
+ (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) va=
l ($ 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)))))
+ (^)))
Modified: trunk/source/compiler/nx1.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/nx1.lisp (original)
+++ trunk/source/compiler/nx1.lisp Tue Aug 16 15:43:43 2011
@@ -221,6 +221,24 @@
(make-acode (%nx1-default-operator)
(nx1-form base)
(nx1-form offset)))
+
+(defnx1 nx1-fixnum-ref-double-float ((%fixnum-ref-double-float)) (base &op=
tional (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 ind=
ex-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))
(arg)
Modified: trunk/source/compiler/nxenv.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/nxenv.lisp (original)
+++ trunk/source/compiler/nxenv.lisp Tue Aug 16 15:43:43 2011
@@ -206,8 +206,8 @@
(make-list . #.(logior operator-assignment-free-mask operator-single-=
valued-mask)) ; exists only so we can stack-cons
(%badarg1 . 0)
(%badarg2 . 0)
- (newblocktag . 0)
- (newgotag . 0)
+ (%fixnum-ref-double-float . #.(logior operator-acode-subforms-mask o=
perator-single-valued-mask))
+ (%fixnum-set-double-float . #.(logior operator-acode-subforms-mask o=
perator-single-valued-mask))
(flet . 0) ; may not be necessary - for dynamic-extent, mostly
; for dynamic-extent, forward refs, etc.
(labels . 0) ; removes 75% of LABELS bogosity
More information about the Openmcl-cvs-notifications
mailing list