[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