[MLton-commit] r5674
Matthew Fluet
fluet at mlton.org
Sun Jun 24 17:48:27 PDT 2007
More tracing and better variables names in shrinkers
----------------------------------------------------------------------
U mlton/trunk/mlton/ssa/shrink.fun
U mlton/trunk/mlton/ssa/shrink2.fun
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/ssa/shrink.fun
===================================================================
--- mlton/trunk/mlton/ssa/shrink.fun 2007-06-24 18:22:05 UTC (rev 5673)
+++ mlton/trunk/mlton/ssa/shrink.fun 2007-06-25 00:48:26 UTC (rev 5674)
@@ -503,6 +503,10 @@
labelMeaning
fun meaningLabel m =
Block.label (Vector.sub (blocks, LabelMeaning.blockIndex m))
+ fun labelArgs l =
+ Block.args (Vector.sub (blocks, labelIndex l))
+ fun meaningArgs m =
+ Block.args (Vector.sub (blocks, LabelMeaning.blockIndex m))
fun save (f, s) =
File.withOut
(concat ["/tmp/", Func.toString (Function.name f),
@@ -704,6 +708,20 @@
Transfer.layout,
Layout.tuple2 (List.layout Statement.layout,
Transfer.layout))
+ val traceSimplifyCase =
+ Trace.trace
+ ("Ssa2.Shrink2.simplifyCase",
+ fn {canMove, cantSimplify, cases, default, gone, test} =>
+ Layout.record [("canMove", List.layout Statement.layout canMove),
+ ("cantSimplify", Layout.str "fn () => ..."),
+ ("gone", Layout.str "fn () => ..."),
+ ("test", VarInfo.layout test),
+ ("cases/default",
+ (Transfer.layout o Transfer.Case)
+ {cases = cases,
+ default = default,
+ test = VarInfo.var test})],
+ Layout.tuple2 (List.layout Statement.layout, Transfer.layout))
val newBlocks = ref []
fun simplifyLabel l =
let
@@ -839,11 +857,7 @@
let
fun isEta (m: LabelMeaning.t,
ps: Position.t vector): bool =
- Vector.length ps
- = (Vector.length
- (Block.args
- (Vector.sub
- (blocks, LabelMeaning.blockIndex m))))
+ Vector.length ps = Vector.length (meaningArgs m)
andalso
Vector.foralli
(ps,
@@ -932,9 +946,10 @@
args = simplifyVars args,
return = simplifyLabel return})
) arg
- and simplifyCase {canMove, cantSimplify,
- cases, default, gone, test: VarInfo.t}
- : Statement.t list * Transfer.t =
+ and simplifyCase arg : Statement.t list * Transfer.t =
+ traceSimplifyCase
+ (fn {canMove, cantSimplify,
+ cases, default, gone, test: VarInfo.t} =>
let
(* tryToEliminate makes sure that the destination meaning
* hasn't already been simplified. If it has, then we can't
@@ -964,8 +979,7 @@
val l = Cases.hd cases
fun isOk (l': Label.t): bool = Label.equals (l, l')
in
- if 0 = Vector.length (Block.args
- (Vector.sub (blocks, labelIndex l)))
+ if 0 = Vector.length (labelArgs l)
andalso Cases.forall (cases, isOk)
andalso (case default of
NONE => true
@@ -975,12 +989,12 @@
tryToEliminate (labelMeaning l)
else
let
- fun findCase (cases, is, args) =
+ fun findCase (cases, isCon, args) =
let
val n = Vector.length cases
- fun doit (j, args) =
+ fun doit (l, args) =
let
- val m = labelMeaning j
+ val m = labelMeaning l
val _ = addLabelMeaning m
val _ = gone ()
in
@@ -991,13 +1005,13 @@
then
(case default of
NONE => (gone (); ([], Bug))
- | SOME j => doit (j, Vector.new0 ()))
+ | SOME l => doit (l, Vector.new0 ()))
else
let
- val (i, j) = Vector.sub (cases, k)
+ val (con, l) = Vector.sub (cases, k)
in
- if is i
- then doit (j, args)
+ if isCon con
+ then doit (l, args)
else loop (k + 1)
end
in
@@ -1020,7 +1034,7 @@
| _ => cantSimplify ()
end
end
- end
+ end) arg
and goto (dst: Label.t, args: VarInfo.t vector)
: Statement.t list * Transfer.t =
gotoMeaning ([], labelMeaning dst, args)
@@ -1239,7 +1253,7 @@
raises = raises,
returns = returns,
start = meaningLabel start}
-(* val _ = save (f, "post") *)
+ val _ = if true then () else save (f, "post")
val _ = Function.clear f
in
f
Modified: mlton/trunk/mlton/ssa/shrink2.fun
===================================================================
--- mlton/trunk/mlton/ssa/shrink2.fun 2007-06-24 18:22:05 UTC (rev 5673)
+++ mlton/trunk/mlton/ssa/shrink2.fun 2007-06-25 00:48:26 UTC (rev 5674)
@@ -508,6 +508,10 @@
labelMeaning
fun meaningLabel m =
Block.label (Vector.sub (blocks, LabelMeaning.blockIndex m))
+ fun labelArgs l =
+ Block.args (Vector.sub (blocks, labelIndex l))
+ fun meaningArgs m =
+ Block.args (Vector.sub (blocks, LabelMeaning.blockIndex m))
fun save (f, s) =
File.withOut
(concat ["/tmp/", Func.toString (Function.name f),
@@ -708,6 +712,20 @@
Transfer.layout,
Layout.tuple2 (List.layout Statement.layout,
Transfer.layout))
+ val traceSimplifyCase =
+ Trace.trace
+ ("Ssa2.Shrink2.simplifyCase",
+ fn {canMove, cantSimplify, cases, default, gone, test} =>
+ Layout.record [("canMove", List.layout Statement.layout canMove),
+ ("cantSimplify", Layout.str "fn () => ..."),
+ ("gone", Layout.str "fn () => ..."),
+ ("test", VarInfo.layout test),
+ ("cases/default",
+ (Transfer.layout o Transfer.Case)
+ {cases = cases,
+ default = default,
+ test = VarInfo.var test})],
+ Layout.tuple2 (List.layout Statement.layout, Transfer.layout))
val newBlocks = ref []
fun simplifyLabel l =
let
@@ -842,10 +860,7 @@
fun isEta (m: LabelMeaning.t,
ps: Position.t vector): bool =
Vector.length ps
- = (Vector.length
- (Block.args
- (Vector.sub
- (blocks, LabelMeaning.blockIndex m))))
+ = Vector.length (meaningArgs m)
andalso
Vector.foralli
(ps,
@@ -934,9 +949,10 @@
args = simplifyVars args,
return = simplifyLabel return})
) arg
- and simplifyCase {canMove, cantSimplify,
- cases, default, gone, test: VarInfo.t}
- : Statement.t list * Transfer.t =
+ and simplifyCase arg : Statement.t list * Transfer.t =
+ traceSimplifyCase
+ (fn {canMove, cantSimplify,
+ cases, default, gone, test: VarInfo.t} =>
let
(* tryToEliminate makes sure that the destination meaning
* hasn't already been simplified. If it has, then we can't
@@ -966,8 +982,7 @@
val l = Cases.hd cases
fun isOk (l': Label.t): bool = Label.equals (l, l')
in
- if 0 = Vector.length (Block.args
- (Vector.sub (blocks, labelIndex l)))
+ if 0 = Vector.length (labelArgs l)
andalso Cases.forall (cases, isOk)
andalso (case default of
NONE => true
@@ -977,12 +992,12 @@
tryToEliminate (labelMeaning l)
else
let
- fun findCase (cases, is, args) =
+ fun findCase (cases, isCon, args) =
let
val n = Vector.length cases
- fun doit (j, args) =
+ fun doit (l, args) =
let
- val m = labelMeaning j
+ val m = labelMeaning l
val () = addLabelMeaning m
val () = gone ()
in
@@ -993,13 +1008,13 @@
then
(case default of
NONE => (gone (); ([], Bug))
- | SOME j => doit (j, Vector.new0 ()))
+ | SOME j => doit (l, Vector.new0 ()))
else
let
- val (i, j) = Vector.sub (cases, k)
+ val (con, l) = Vector.sub (cases, k)
in
- if is i
- then doit (j, args)
+ if isCon con
+ then doit (l, args)
else loop (k + 1)
end
in
@@ -1022,7 +1037,7 @@
in
case !value of
SOME (Value.Object
- {args, con = SOME con, ...}) =>
+ {con = SOME con, ...}) =>
findCase (cases,
fn c => Con.equals (con, c),
if 0 = Vector.length args
@@ -1033,7 +1048,7 @@
| _ => cantSimplify ()
end
end
- end
+ end) arg
and goto (dst: Label.t, args: VarInfo.t vector)
: Statement.t list * Transfer.t =
gotoMeaning ([], labelMeaning dst, args)
@@ -1308,7 +1323,7 @@
raises = raises,
returns = returns,
start = meaningLabel start}
-(* val () = save (f, "post") *)
+ val () = if true then () else save (f, "post")
val () = Function.clear f
in
f
More information about the MLton-commit
mailing list