[MLton-devel] cvs commit: simple overflow detection elimination
Stephen Weeks
sweeks@users.sourceforge.net
Thu, 14 Nov 2002 14:25:42 -0800
sweeks 02/11/14 14:25:42
Modified: mlton/atoms prim.fun prim.sig
mlton/control control.sig control.sml
mlton/main main.sml
mlton/ssa redundant-tests.fun
Log:
Added a test to the redundant-tests pass that will sometimes eliminate
the overflow test when adding or subtracting 1. In particular, it
will eliminate it in the following cases:
if x < y
then ... x + 1 ...
else ... y - 1 ...
Maybe more importantly, in adding this, I noticed that there was a bug
introduced about a year ago in redundant-tests that caused it not to
run at all. I also fixed that bug.
Revision Changes Path
1.40 +1 -0 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -r1.39 -r1.40
--- prim.fun 7 Nov 2002 20:49:10 -0000 1.39
+++ prim.fun 14 Nov 2002 22:25:41 -0000 1.40
@@ -564,6 +564,7 @@
val intAddCheck = make Name.Int_addCheck
val intMul = make Name.Int_mul
val intMulCheck = make Name.Int_mulCheck
+ val intSub = make Name.Int_sub
val intSubCheck = make Name.Int_subCheck
end
1.32 +1 -0 mlton/mlton/atoms/prim.sig
Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- prim.sig 2 Nov 2002 03:37:38 -0000 1.31
+++ prim.sig 14 Nov 2002 22:25:41 -0000 1.32
@@ -285,6 +285,7 @@
val intAddCheck: t
val intMul: t
val intMulCheck: t
+ val intSub: t
val intSubCheck: t
val isCommutative: t -> bool
(*
1.55 +4 -0 mlton/mlton/control/control.sig
Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.54
retrieving revision 1.55
diff -u -r1.54 -r1.55
--- control.sig 2 Nov 2002 03:37:40 -0000 1.54
+++ control.sig 14 Nov 2002 22:25:41 -0000 1.55
@@ -35,10 +35,14 @@
val defines: string list ref
+ (* whether the arithmetic primitives detect overflow *)
val detectOverflow: bool ref
(* List of optimization passes to skip. *)
val dropPasses: string list ref
+
+ (* whether optimization passes should eliminate useless overflow tests *)
+ val eliminateOverflow: bool ref
val exnHistory: bool ref
1.70 +5 -0 mlton/mlton/control/control.sml
Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.69
retrieving revision 1.70
diff -u -r1.69 -r1.70
--- control.sml 5 Nov 2002 20:27:07 -0000 1.69
+++ control.sml 14 Nov 2002 22:25:41 -0000 1.70
@@ -52,6 +52,11 @@
default = [],
toString = List.toString String.toString}
+val eliminateOverflow =
+ control {name = "eliminate overflow",
+ default = true,
+ toString = Bool.toString}
+
val exnHistory = control {name = "exn history",
default = false,
toString = Bool.toString}
1.93 +3 -0 mlton/mlton/main/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.92
retrieving revision 1.93
diff -u -r1.92 -r1.93
--- main.sml 7 Nov 2002 01:36:55 -0000 1.92
+++ main.sml 14 Nov 2002 22:25:41 -0000 1.93
@@ -110,6 +110,9 @@
SpaceString (fn s => List.push (dropPasses, s))),
(Expert, "D", "define", "define a constant for gcc",
String (fn s => (List.push (defines, s)))),
+ (Expert, "eliminate-overflow", " {true|false}",
+ "eliminate useless overflow tests",
+ boolRef Control.eliminateOverflow),
(Normal, "exn-history", " {false|true}",
"enable Exn.history",
boolRef Control.exnHistory),
1.9 +121 -1 mlton/mlton/ssa/redundant-tests.fun
Index: redundant-tests.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/redundant-tests.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- redundant-tests.fun 16 Apr 2002 12:10:53 -0000 1.8
+++ redundant-tests.fun 14 Nov 2002 22:25:42 -0000 1.9
@@ -171,7 +171,11 @@
val (trueVar, t) = make Con.truee
val (falseVar, f) = make Con.falsee
end
- val globals = Vector.concat [Vector.new2 (t, f), globals]
+ val one = Var.newNoname ()
+ val oneS = Statement.T {exp = Exp.Const (Const.fromInt 1),
+ var = SOME one,
+ ty = Type.int}
+ val globals = Vector.concat [Vector.new3 (t, f, oneS), globals]
val shrink = shrinkFunction globals
val numSimplified = ref 0
fun simplifyFunction f =
@@ -294,6 +298,20 @@
(! (#facts (labelInfo label)))])
end))
(* Transformation. *)
+ fun isFact (l: Label.t, p: Fact.t -> bool): bool =
+ let
+ fun loop (l: Label.t) =
+ let
+ val {ancestor, facts, ...} = labelInfo l
+ in
+ List.exists (!facts, p)
+ orelse (case !ancestor of
+ NONE => false
+ | SOME l => loop l)
+ end
+ in
+ loop l
+ end
fun determine (l: Label.t, f: Fact.t) =
let
fun loop {ancestor, facts, ...} =
@@ -349,6 +367,107 @@
| Unknown => statement)
| _ => statement)
end)
+ val noChange = (statements, transfer)
+ fun arith (args: Var.t vector,
+ prim: Prim.t,
+ success: Label.t)
+ : Statement.t vector * Transfer.t =
+ let
+ fun simplify (prim: Prim.t, x: Var.t) =
+ let
+ val res = Var.newNoname ()
+ in
+ (Vector.concat
+ [statements,
+ Vector.new1
+ (Statement.T
+ {exp = PrimApp {args = Vector.new2 (x, one),
+ prim = prim,
+ targs = Vector.new0 ()},
+ ty = Type.int,
+ var = SOME res})],
+ Goto {args = Vector.new1 res,
+ dst = success})
+ end
+ fun add1 (x: Var.t) =
+ if isFact (label, fn Fact.T {lhs, rel, rhs} =>
+ case (lhs, rel, rhs) of
+ (Oper.Var x', Rel.LT, _) =>
+ Var.equals (x, x')
+ | (Oper.Var x', Rel.LE, Oper.Const c) =>
+ Var.equals (x, x')
+ andalso (case Const.node c of
+ Const.Node.Int c =>
+ c < Int.maxInt
+ | _ => Error.bug "strange fact")
+ | _ => false)
+ then simplify (Prim.intAdd, x)
+ else noChange
+ fun sub1 (x: Var.t) =
+ if isFact (label, fn Fact.T {lhs, rel, rhs} =>
+ case (lhs, rel, rhs) of
+ (_, Rel.LT, Oper.Var x') =>
+ Var.equals (x, x')
+ | (Oper.Const c, Rel.LE, Oper.Var x') =>
+ Var.equals (x, x')
+ andalso (case Const.node c of
+ Const.Node.Int c =>
+ c > Int.minInt
+ | _ => Error.bug "strange fact")
+ | _ => false)
+ then simplify (Prim.intSub, x)
+ else noChange
+ fun add (c: Const.t, x: Var.t) =
+ case Const.node c of
+ Const.Node.Int i =>
+ if i = 1
+ then add1 x
+ else if i = ~1
+ then sub1 x
+ else noChange
+ | _ => Error.bug "add of strange const"
+ datatype z = datatype Prim.Name.t
+ in
+ case Prim.name prim of
+ Int_addCheck =>
+ let
+ val x1 = Vector.sub (args, 0)
+ val x2 = Vector.sub (args, 1)
+ in
+ case varInfo x1 of
+ Const c => add (c, x2)
+ | _ => (case varInfo x2 of
+ Const c => add (c, x1)
+ | _ => noChange)
+ end
+ | Int_subCheck =>
+ let
+ val x1 = Vector.sub (args, 0)
+ val x2 = Vector.sub (args, 1)
+ in
+ case varInfo x2 of
+ Const c =>
+ (case Const.node c of
+ Const.Node.Int i =>
+ if i = ~1
+ then add1 x1
+ else if i = 1
+ then sub1 x1
+ else noChange
+ | _ =>
+ Error.bug "sub of strage const")
+ | _ => noChange
+ end
+ | _ => noChange
+ end
+ val (statements, transfer) =
+ if !Control.eliminateOverflow
+ then
+ case transfer of
+ Arith {args, prim, success, ...} =>
+ arith (args, prim, success)
+ | _ => noChange
+ else noChange
in
Block.T {label = label,
args = args,
@@ -369,6 +488,7 @@
let open Layout
in seq [str "numSimplified = ", Int.layout (!numSimplified)]
end)
+ val functions = List.revMap (functions, simplifyFunction)
val program =
Program.T {datatypes = datatypes,
globals = globals,
-------------------------------------------------------
This sf.net email is sponsored by: To learn the basics of securing
your web site with SSL, click here to get a FREE TRIAL of a Thawte
Server Certificate: http://www.gothawte.com/rd524.html
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel