[MLton-devel] cvs commit: unreachable blocks bugfix

Stephen Weeks sweeks@users.sourceforge.net
Tue, 20 Aug 2002 21:48:32 -0700


sweeks      02/08/20 21:48:32

  Modified:    mlton/ssa constant-propagation.fun shrink.fun shrink.sig
                        type-check.fun useless.fun
  Log:
  Fixed a bug in constant-propagation and useless that was triggered when they
  received an input with unreachable blocks.  Both passes would fail in such a
  situation because they do analysis only on reachable blocks, but rewrite based
  on unreachable ones.  The fix was to run a prepass to eliminate unreachable
  blocks.
  
  There is still possibly a similar bug in local-ref.
  
  Two other ways to fix the problem would be to
  
  1. disallow unreachable blocks entirely.
  2. change the buggy passes to do rewriting only on reachable blocks.
  
  (1) seems pretty expensive to me in terms of compiler run time, because every
  shrinker pass would have to be followed by a pass that eliminates unreachable
  blocks.
  
  (2) might be OK, but requires some more complicated rewriting of the offending
  passes than what I did here.

Revision  Changes    Path
1.10      +3 -2      mlton/mlton/ssa/constant-propagation.fun

Index: constant-propagation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/constant-propagation.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- constant-propagation.fun	10 Apr 2002 07:02:20 -0000	1.9
+++ constant-propagation.fun	21 Aug 2002 04:48:31 -0000	1.10
@@ -514,9 +514,10 @@
 (*                     simplify                      *)
 (* ------------------------------------------------- *)
 
-fun simplify (program as Program.T {datatypes, globals, functions, main})
-   : Program.t =
+fun simplify (program: Program.t): Program.t =
    let
+      val program as Program.T {datatypes, globals, functions, main} =
+	 eliminateDeadBlocks program
       val {varIsMultiDefed, ...} = Multi.multi program
       val once = not o varIsMultiDefed
       val {get = conInfo: Con.t -> {result: Type.t,



1.18      +29 -0     mlton/mlton/ssa/shrink.fun

Index: shrink.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/shrink.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- shrink.fun	6 Jul 2002 17:22:07 -0000	1.17
+++ shrink.fun	21 Aug 2002 04:48:31 -0000	1.18
@@ -1286,4 +1286,33 @@
 		 main = main}
    end
 
+fun eliminateDeadBlocks (Program.T {datatypes, globals, functions, main}) =
+   let
+      val functions =
+	 List.revMap
+	 (functions, fn f =>
+	  let
+	     val {args, blocks, name, raises, returns, start} = Function.dest f
+	     val {get, set, rem} =
+		Property.getSetOnce (Label.plist, Property.initConst false)
+	     val _ = Function.dfs (f, fn Block.T {label, ...} =>
+				   (set (label, true)
+				    ; fn () => ()))
+	     val blocks = Vector.keepAll (blocks, get o Block.label)
+	     val _ = Vector.foreach (blocks, rem o Block.label)
+	  in
+	     Function.new {args = args,
+			   blocks = blocks,
+			   name = name,
+			   raises = raises,
+			   returns = returns,
+			   start = start}
+	  end)
+   in
+      Program.T {datatypes = datatypes,
+		 globals = globals,
+		 functions = functions,
+		 main = main}
+   end
+
 end



1.9       +1 -0      mlton/mlton/ssa/shrink.sig

Index: shrink.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/shrink.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- shrink.sig	10 Apr 2002 07:02:20 -0000	1.8
+++ shrink.sig	21 Aug 2002 04:48:32 -0000	1.9
@@ -17,6 +17,7 @@
    sig
       include SHRINK_STRUCTS
 
+      val eliminateDeadBlocks: Program.t -> Program.t
       val shrinkFunction: Statement.t vector -> Function.t -> Function.t
 (*      val shrinkFunctionNoDelete: Function.t -> Function.t *)
       val shrink: Program.t -> Program.t



1.18      +0 -2      mlton/mlton/ssa/type-check.fun

Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/type-check.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- type-check.fun	10 Apr 2002 07:02:21 -0000	1.17
+++ type-check.fun	21 Aug 2002 04:48:32 -0000	1.18
@@ -12,8 +12,6 @@
 datatype z = datatype Exp.t
 datatype z = datatype Transfer.t
 
-fun equalss (ts, ts') = List.equals (ts, ts', Type.equals)
-
 structure Graph = DirectedGraph
 structure Node = Graph.Node
 



1.11      +6 -3      mlton/mlton/ssa/useless.fun

Index: useless.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/useless.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- useless.fun	10 Apr 2002 07:02:21 -0000	1.10
+++ useless.fun	21 Aug 2002 04:48:32 -0000	1.11
@@ -361,8 +361,10 @@
 
 structure Exists = Value.Exists
 
-fun useless (program as Program.T {datatypes, globals, functions, main}) =
+fun useless (program: Program.t): Program.t =
    let
+      val program as Program.T {datatypes, globals, functions, main} =
+	 eliminateDeadBlocks program
       val {get = conInfo: Con.t -> {args: Value.t vector,
 				    argTypes: Type.t vector,
 				    value: unit -> Value.t},
@@ -445,7 +447,7 @@
 
 	 type value = t
 
-	 fun primApp {prim, targs, args: t vector, resultVar, resultType} =
+	 fun primApp {prim, targs, args: t vector, resultVar = _, resultType} =
 	    let
 	       val result = fromType resultType
 	       fun return v = coerce {from = v, to = result}
@@ -975,7 +977,8 @@
       fun doitFunction f =
 	 let
 	    val {name, args, start, blocks, returns, raises} = Function.dest f
-	    val {args = argsvs, returns = returnvs, raises = raisevs, ...} = func name
+	    val {args = argsvs, returns = returnvs, raises = raisevs, ...} =
+	       func name
 	    val args = keepUsefulArgs args
 	    val (blocks, blocks') =
 	       Vector.mapAndFold





-------------------------------------------------------
This sf.net email is sponsored by: OSDN - Tired of that same old
cell phone?  Get a new here for FREE!
https://www.inphonic.com/r.asp?r=sourceforge1&refcode1=vs3390
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel