[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