[MLton] cvs commit: Improvements to SSA{,2} shrinker in the presence of profiling
Matthew Fluet
fluet@mlton.org
Sat, 11 Jun 2005 10:02:03 -0700
fluet 05/06/11 10:02:02
Modified: mlton/ssa shrink.fun shrink2.fun
Log:
MAIL Improvements to SSA{,2} shrinker in the presence of profiling
Made the shrinker a bit more roubust in the presence of profiling
annotations.
Previously, we did not simplify blocks with only profile statements
and a Goto or Case transfer. For example:
Enter not <basis>/misc/basic.sml: 16
case x_1643 of
true => L_917 | false => L_909
L_909 ()
Leave not <basis>/misc/basic.sml: 16
L_910 (global_20)
L_911 ()
L_912 (global_119)
L_913 (x_1631)
x_1634 = (x_1631, x_1633)
x_1632 = ::_7 (x_1633, x_1631)
L_914 (x_1632)
L_914 (x_1635)
Leave List.mapPartial.fn <basis>/list/list.sml: 68
Leave List.foldl.loop <basis>/list/list.sml: 39
loop_76 (x_1635, x_1636)
L_915 ()
L_914 (x_1633)
L_912 (x_1637)
Leave List.filter.fn <basis>/list/list.sml: 73
case x_1637 of
NONE_4 => L_915 | SOME_3 => L_913
L_916 ()
x_1638 = SOME_3 (x_1639)
L_912 (x_1638)
L_910 (x_1640)
Leave StreamIOExtraFile.closeOut.fn <basis>/io/stream-io.fun: 890
case x_1640 of
true => L_916 | false => L_911
L_917 ()
Leave not <basis>/misc/basic.sml: 16
L_910 (global_43)
If the profile statements were removed, then the shrinker would (and
continues to) simplify the above to:
case x_1643 of
true => L_917 | false => L_909
L_909 ()
x_1632 = ::_7 (x_1633, x_1641)
loop_76 (x_1632, x_1642)
L_917 ()
loop_76 (x_1633, x_1642)
The old colde would only eliminate the assignment to x_1634:
Enter not <basis>/misc/basic.sml: 16
case x_1643 of
true => L_917 | false => L_909
L_909 ()
Leave not <basis>/misc/basic.sml: 16
L_910 (global_20)
L_917 ()
Leave not <basis>/misc/basic.sml: 16
L_910 (global_43)
L_910 (x_1640)
Leave StreamIOExtraFile.closeOut.fn <basis>/io/stream-io.fun: 890
case x_1640 of
true => L_916 | false => L_911
L_911 ()
L_912 (global_119)
L_916 ()
x_1638 = SOME_3 (x_1641)
L_912 (x_1638)
L_912 (x_1637)
Leave List.filter.fn <basis>/list/list.sml: 73
case x_1637 of
NONE_4 => L_915 | SOME_3 => L_913
L_913 (x_1631)
x_1632 = ::_7 (x_1633, x_1631)
L_914 (x_1632)
L_915 ()
L_914 (x_1633)
L_914 (x_1635)
Leave List.mapPartial.fn <basis>/list/list.sml: 68
Leave List.foldl.loop <basis>/list/list.sml: 39
loop_76 (x_1635, x_1642)
This is a significant penalty, leading to over 7X slowdown on the
wc-scanStream benchmark when profiling is enabled.
There is a very simple solution: duplicate the profile statements when
a trace through a Case block is taken. Previously, this was
specifically ruled out by only simplifying Case blocks where
0 = Vector.length statements.
A similar failure to simplify Goto blocks was due a similar condition
on the length of the statements vector. Note, that an eta-block
retains the condition that the statements vector is of length 0.
As stated above, this solves the performance problem with
wc-scanStream. Unfortunately, it did not significantly affect any of
the other benchmarks. The new outlier in the presence of profiling is
checksum.
MLton0 -- mlton -profile no
MLton1 -- mlton -profile drop
run time ratio
benchmark MLton0 MLton1
barnes-hut 1.00 1.04
boyer 1.00 1.04
checksum 1.00 1.65
count-graphs 1.00 1.02
DLXSimulator 1.00 1.00
fft 1.00 1.02
fib 1.00 1.36
flat-array 1.00 1.00
hamlet 1.00 1.04
imp-for 1.00 1.00
knuth-bendix 1.00 1.20
lexgen 1.00 1.05
life 1.00 1.01
logic 1.00 1.03
mandelbrot 1.00 1.00
matrix-multiply 1.00 0.99
md5 1.00 1.40
merge 1.00 1.00
mlyacc 1.00 1.02
model-elimination 1.00 1.03
mpuz 1.00 1.00
nucleic 1.00 0.99
output1 1.00 0.97
peek 1.00 1.25
psdes-random 1.00 1.10
ratio-regions 1.00 1.13
ray 1.00 1.07
raytrace 1.00 1.04
simple 1.00 1.03
smith-normal-form 1.00 1.00
tailfib 1.00 0.96
tak 1.00 1.36
tensor 1.00 1.00
tsp 1.00 1.01
tyan 1.00 1.07
vector-concat 1.00 0.99
vector-rev 1.00 1.00
vliw 1.00 1.03
wc-input1 1.00 1.00
wc-scanStream 1.00 0.92
zebra 1.00 1.02
zern 1.00 1.00
Revision Changes Path
1.48 +88 -45 mlton/mlton/ssa/shrink.fun
Index: shrink.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/shrink.fun,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -r1.47 -r1.48
--- shrink.fun 8 Jun 2005 20:31:43 -0000 1.47
+++ shrink.fun 11 Jun 2005 17:02:01 -0000 1.48
@@ -124,9 +124,11 @@
and aux =
Block
| Bug
- | Case of {cases: Cases.t,
+ | Case of {canMove: Statement.t list,
+ cases: Cases.t,
default: Label.t option}
- | Goto of {dst: t,
+ | Goto of {canMove: Statement.t list,
+ dst: t,
args: Positions.t}
| Raise of {args: Positions.t,
canMove: Statement.t list}
@@ -150,7 +152,7 @@
Block => str "Block "
| Bug => str "Bug"
| Case _ => str "Case"
- | Goto {dst, args} =>
+ | Goto {dst, args, ...} =>
seq [str "Goto ",
tuple [layout dst, Positions.layout args]]
| Raise {args, ...} =>
@@ -319,9 +321,14 @@
blockIndex = i,
label = Block.label (Vector.sub (blocks, i))}
fun normal () = doit LabelMeaning.Block
+ fun canMove () =
+ Vector.toListMap
+ (statements, fn Statement.T {exp, ty, ...} =>
+ Statement.T {exp = exp, ty = ty, var = NONE})
fun rr (xs: Var.t vector, make) =
let
val _ = incVars xs
+(*
val n = Vector.length statements
fun loop (i, ac) =
if i = n
@@ -346,6 +353,15 @@
in
loop (0, [])
end
+*)
+ in
+ if Vector.forall (statements, Statement.isProfile)
+ andalso (0 = Vector.length xs
+ orelse 0 < Vector.length args)
+ then doit (make {args = extract xs,
+ canMove = canMove ()})
+ else normal ()
+ end
in
case transfer of
Arith {args, overflow, success, ...} =>
@@ -354,7 +370,7 @@
; incLabel success
; normal ())
| Bug =>
- if 0 = Vector.length statements
+ if Vector.forall (statements, Statement.isProfile)
andalso (case returns of
NONE => true
| SOME ts =>
@@ -380,13 +396,14 @@
val _ = Cases.foreach (cases, incLabel)
val _ = Option.app (default, incLabel)
in
- if 0 = Vector.length statements
+ if Vector.forall (statements, Statement.isProfile)
andalso not (Array.sub (isHeader, i))
andalso 1 = Vector.length args
andalso 1 = numVarOccurrences test
andalso Var.equals (test, #1 (Vector.sub (args, 0)))
then
- doit (LabelMeaning.Case {cases = cases,
+ doit (LabelMeaning.Case {canMove = canMove (),
+ cases = cases,
default = default})
else
normal ()
@@ -396,12 +413,14 @@
val _ = incVars actuals
val m = labelMeaning dst
in
- if 0 <> Vector.length statements
+ if Vector.exists (statements, not o Statement.isProfile)
orelse Array.sub (isHeader, i)
then (incLabelMeaning m
; normal ())
else
- if Vector.equals (args, actuals, fn ((x, _), x') =>
+ if 0 = Vector.length statements
+ andalso
+ Vector.equals (args, actuals, fn ((x, _), x') =>
Var.equals (x, x')
andalso 1 = numVarOccurrences x)
then m (* It's an eta. *)
@@ -434,22 +453,28 @@
Free x => Free x
| Formal i => Vector.sub (ps, i)
end)
+ val canMove' = canMove ()
val a =
case LabelMeaning.aux m of
- Block => Goto {dst = m,
- args = ps}
+ Block =>
+ Goto {canMove = canMove',
+ dst = m,
+ args = ps}
| Bug => Bug
- | Case _ => Goto {dst = m,
- args = ps}
- | Goto {dst, args} =>
- Goto {dst = dst,
+ | Case _ =>
+ Goto {canMove = canMove',
+ dst = m,
+ args = ps}
+ | Goto {canMove, dst, args} =>
+ Goto {canMove = canMove' @ canMove,
+ dst = dst,
args = extract args}
| Raise {args, canMove} =>
Raise {args = extract args,
- canMove = canMove}
+ canMove = canMove' @ canMove}
| Return {args, canMove} =>
Return {args = extract args,
- canMove = canMove}
+ canMove = canMove' @ canMove}
in
doit a
end
@@ -605,7 +630,7 @@
()
end
| Bug => ()
- | Case {cases, default} =>
+ | Case {cases, default, ...} =>
(Cases.foreach (cases, deleteLabel)
; Option.app (default, deleteLabel))
| Goto {dst, ...} => deleteLabelMeaning dst
@@ -659,13 +684,15 @@
Trace.trace ("Shrink.forceMeaningBlock",
layoutLabelMeaning, Unit.layout)
val traceSimplifyBlock =
- Trace.trace ("Shrink.simplifyBlock",
- layoutLabel o Block.label,
- Layout.tuple2 (List.layout Statement.layout,
- Transfer.layout))
+ Trace.trace2 ("Shrink.simplifyBlock",
+ List.layout Statement.layout,
+ layoutLabel o Block.label,
+ Layout.tuple2 (List.layout Statement.layout,
+ Transfer.layout))
val traceGotoMeaning =
- Trace.trace2
+ Trace.trace3
("Shrink.gotoMeaning",
+ List.layout Statement.layout,
layoutLabelMeaning,
Vector.layout VarInfo.layout,
Layout.tuple2 (List.layout Statement.layout, Transfer.layout))
@@ -709,11 +736,14 @@
datatype z = datatype LabelMeaning.aux
in
case aux of
- Block => simplifyBlock block
+ Block => simplifyBlock ([], block)
| Bug => ([], Transfer.Bug)
- | Case _ => simplifyBlock block
- | Goto {dst, args} =>
- gotoMeaning (dst, Vector.map (args, extract))
+ | Case _ => simplifyBlock ([], block)
+ | Goto {canMove, dst, args} =>
+ gotoMeaning
+ (canMove,
+ dst,
+ Vector.map (args, extract))
| Raise z => rr (z, Transfer.Raise)
| Return z => rr (z, Transfer.Return)
end
@@ -729,14 +759,20 @@
end) arg
and simplifyBlock arg : Statement.t list * Transfer.t =
traceSimplifyBlock
- (fn (Block.T {statements, transfer, ...}) =>
+ (fn (canMoveIn, Block.T {statements, transfer, ...}) =>
let
- val fs = Vector.map (statements, evalStatement)
+ val f = evalStatements statements
val (ss, transfer) = simplifyTransfer transfer
- val statements = Vector.foldr (fs, ss, fn (f, ss) => f ss)
in
- (statements, transfer)
+ (canMoveIn @ (f ss), transfer)
end) arg
+ and evalStatements (ss: Statement.t vector)
+ : Statement.t list -> Statement.t list =
+ let
+ val fs = Vector.map (ss, evalStatement)
+ in
+ fn ss => Vector.foldr (fs, ss, fn (f, ss) => f ss)
+ end
and simplifyTransfer arg : Statement.t list * Transfer.t =
traceSimplifyTransfer
(fn (t: Transfer.t) =>
@@ -882,7 +918,8 @@
default = Option.map (default, simplifyLabel)})
in
simplifyCase
- {cantSimplify = cantSimplify,
+ {canMove = [],
+ cantSimplify = cantSimplify,
cases = cases,
default = default,
gone = fn () => (Cases.foreach (cases, deleteLabel)
@@ -897,7 +934,8 @@
args = simplifyVars args,
return = simplifyLabel return})
) arg
- and simplifyCase {cantSimplify, cases, default, gone, test: VarInfo.t}
+ and simplifyCase {canMove, cantSimplify,
+ cases, default, gone, test: VarInfo.t}
: Statement.t list * Transfer.t =
let
(* tryToEliminate makes sure that the destination meaning
@@ -915,13 +953,13 @@
val _ = addLabelIndex i
val _ = gone ()
in
- gotoMeaning (m, Vector.new0 ())
+ gotoMeaning (canMove, m, Vector.new0 ())
end
end
in
if Cases.isEmpty cases
then (case default of
- NONE => ([], Bug)
+ NONE => (canMove, Bug)
| SOME l => tryToEliminate (labelMeaning l))
else
let
@@ -948,7 +986,7 @@
val _ = addLabelMeaning m
val _ = gone ()
in
- gotoMeaning (m, args)
+ gotoMeaning (canMove, m, args)
end
fun loop k =
if k = n
@@ -995,10 +1033,11 @@
end
and goto (dst: Label.t, args: VarInfo.t vector)
: Statement.t list * Transfer.t =
- gotoMeaning (labelMeaning dst, args)
+ gotoMeaning ([], labelMeaning dst, args)
and gotoMeaning arg : Statement.t list * Transfer.t =
traceGotoMeaning
- (fn (m as LabelMeaning.T {aux, blockIndex = i, ...},
+ (fn (canMoveIn,
+ m as LabelMeaning.T {aux, blockIndex = i, ...},
args: VarInfo.t vector) =>
let
val n = Array.sub (inDegree, i)
@@ -1014,13 +1053,13 @@
(Block.args b, args, fn ((x, _), vi) =>
setVarInfo (x, vi))
in
- simplifyBlock b
+ simplifyBlock (canMoveIn, b)
end
else
let
val _ = forceMeaningBlock m
in
- ([],
+ (canMoveIn,
Goto {dst = Block.label (Vector.sub (blocks, i)),
args = uses args})
end
@@ -1029,19 +1068,21 @@
Position.Formal n => Vector.sub (args, n)
| Position.Free x => varInfo x
fun rr ({args, canMove}, make) =
- (canMove, make (Vector.map (args, use o extract)))
+ (canMoveIn @ canMove,
+ make (Vector.map (args, use o extract)))
datatype z = datatype LabelMeaning.aux
in
case aux of
Block => normal ()
- | Bug => ([], Transfer.Bug)
- | Case {cases, default} =>
- simplifyCase {cantSimplify = normal,
+ | Bug => ((*canMoveIn*)[], Transfer.Bug)
+ | Case {canMove, cases, default} =>
+ simplifyCase {canMove = canMoveIn @ canMove,
+ cantSimplify = normal,
cases = cases,
default = default,
gone = fn () => deleteLabelMeaning m,
test = Vector.sub (args, 0)}
- | Goto {dst, args} =>
+ | Goto {canMove, dst, args} =>
if Array.sub (isHeader, i)
orelse Array.sub (isBlock, i)
then normal ()
@@ -1054,7 +1095,9 @@
then addLabelMeaning dst
else ()
in
- gotoMeaning (dst, Vector.map (args, extract))
+ gotoMeaning (canMoveIn @ canMove,
+ dst,
+ Vector.map (args, extract))
end
| Raise z => rr (z, Transfer.Raise)
| Return z => rr (z, Transfer.Return)
1.15 +75 -41 mlton/mlton/ssa/shrink2.fun
Index: shrink2.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/shrink2.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- shrink2.fun 8 Jun 2005 20:31:43 -0000 1.14
+++ shrink2.fun 11 Jun 2005 17:02:01 -0000 1.15
@@ -132,9 +132,11 @@
and aux =
Block
| Bug
- | Case of {cases: Cases.t,
+ | Case of {canMove: Statement.t list,
+ cases: Cases.t,
default: Label.t option}
- | Goto of {dst: t,
+ | Goto of {canMove: Statement.t list,
+ dst: t,
args: Positions.t}
| Raise of {args: Positions.t,
canMove: Statement.t list}
@@ -158,7 +160,7 @@
Block => str "Block "
| Bug => str "Bug"
| Case _ => str "Case"
- | Goto {dst, args} =>
+ | Goto {dst, args, ...} =>
seq [str "Goto ",
tuple [layout dst, Positions.layout args]]
| Raise {args, ...} =>
@@ -331,9 +333,12 @@
blockIndex = i,
label = Block.label (Vector.sub (blocks, i))}
fun normal () = doit LabelMeaning.Block
+ fun canMove () =
+ Vector.toList statements
fun rr (xs: Var.t vector, make) =
let
val () = incVars xs
+(*
val n = Vector.length statements
fun loop (i, ac) =
if i = n
@@ -354,6 +359,15 @@
in
loop (0, [])
end
+*)
+ in
+ if Vector.forall (statements, Statement.isProfile)
+ andalso (0 = Vector.length xs
+ orelse 0 < Vector.length args)
+ then doit (make {args = extract xs,
+ canMove = canMove ()})
+ else normal ()
+ end
in
case transfer of
Arith {args, overflow, success, ...} =>
@@ -388,13 +402,14 @@
val () = Cases.foreach (cases, incLabel)
val () = Option.app (default, incLabel)
in
- if 0 = Vector.length statements
+ if Vector.forall(statements, Statement.isProfile)
andalso not (Array.sub (isHeader, i))
andalso 1 = Vector.length args
andalso 1 = numVarOccurrences test
andalso Var.equals (test, #1 (Vector.sub (args, 0)))
then
- doit (LabelMeaning.Case {cases = cases,
+ doit (LabelMeaning.Case {canMove = canMove (),
+ cases = cases,
default = default})
else
normal ()
@@ -404,12 +419,14 @@
val () = incVars actuals
val m = labelMeaning dst
in
- if 0 <> Vector.length statements
+ if Vector.exists (statements, not o Statement.isProfile)
orelse Array.sub (isHeader, i)
then (incLabelMeaning m
; normal ())
else
- if Vector.equals (args, actuals, fn ((x, _), x') =>
+ if 0 = Vector.length statements
+ andalso
+ Vector.equals (args, actuals, fn ((x, _), x') =>
Var.equals (x, x')
andalso 1 = numVarOccurrences x)
then m (* It's an eta. *)
@@ -442,22 +459,28 @@
Free x => Free x
| Formal i => Vector.sub (ps, i)
end)
+ val canMove' = canMove ()
val a =
case LabelMeaning.aux m of
- Block => Goto {dst = m,
- args = ps}
+ Block =>
+ Goto {canMove = canMove',
+ dst = m,
+ args = ps}
| Bug => Bug
- | Case _ => Goto {dst = m,
- args = ps}
- | Goto {dst, args} =>
- Goto {dst = dst,
+ | Case _ =>
+ Goto {canMove = canMove',
+ dst = m,
+ args = ps}
+ | Goto {canMove, dst, args} =>
+ Goto {canMove = canMove' @ canMove,
+ dst = dst,
args = extract args}
| Raise {args, canMove} =>
Raise {args = extract args,
- canMove = canMove}
+ canMove = canMove' @ canMove}
| Return {args, canMove} =>
Return {args = extract args,
- canMove = canMove}
+ canMove = canMove' @ canMove}
in
doit a
end
@@ -613,7 +636,7 @@
()
end
| Bug => ()
- | Case {cases, default} =>
+ | Case {cases, default, ...} =>
(Cases.foreach (cases, deleteLabel)
; Option.app (default, deleteLabel))
| Goto {dst, ...} => deleteLabelMeaning dst
@@ -666,13 +689,15 @@
Trace.trace ("Shrink2.forceMeaningBlock",
layoutLabelMeaning, Unit.layout)
val traceSimplifyBlock =
- Trace.trace ("Shrink2.simplifyBlock",
- layoutLabel o Block.label,
- Layout.tuple2 (List.layout Statement.layout,
- Transfer.layout))
+ Trace.trace2 ("Shrink2.simplifyBlock",
+ List.layout Statement.layout,
+ layoutLabel o Block.label,
+ Layout.tuple2 (List.layout Statement.layout,
+ Transfer.layout))
val traceGotoMeaning =
- Trace.trace2
+ Trace.trace3
("Shrink2.gotoMeaning",
+ List.layout Statement.layout,
layoutLabelMeaning,
Vector.layout VarInfo.layout,
Layout.tuple2 (List.layout Statement.layout, Transfer.layout))
@@ -715,11 +740,13 @@
datatype z = datatype LabelMeaning.aux
in
case aux of
- Block => simplifyBlock block
+ Block => simplifyBlock ([], block)
| Bug => ([], Transfer.Bug)
- | Case _ => simplifyBlock block
- | Goto {dst, args} =>
- gotoMeaning (dst, Vector.map (args, extract))
+ | Case _ => simplifyBlock ([], block)
+ | Goto {canMove, dst, args} =>
+ gotoMeaning (canMove,
+ dst,
+ Vector.map (args, extract))
| Raise z => rr (z, Transfer.Raise)
| Return z => rr (z, Transfer.Return)
end
@@ -735,12 +762,12 @@
end) arg
and simplifyBlock arg : Statement.t list * Transfer.t =
traceSimplifyBlock
- (fn (Block.T {statements, transfer, ...}) =>
+ (fn (canMoveIn, Block.T {statements, transfer, ...}) =>
let
val f = evalStatements statements
val (ss, transfer) = simplifyTransfer transfer
in
- (f ss, transfer)
+ (canMoveIn @ (f ss), transfer)
end) arg
and evalStatements (ss: Statement.t vector)
: Statement.t list -> Statement.t list =
@@ -894,7 +921,8 @@
default = Option.map (default, simplifyLabel)})
in
simplifyCase
- {cantSimplify = cantSimplify,
+ {canMove = [],
+ cantSimplify = cantSimplify,
cases = cases,
default = default,
gone = fn () => (Cases.foreach (cases, deleteLabel)
@@ -909,7 +937,8 @@
args = simplifyVars args,
return = simplifyLabel return})
) arg
- and simplifyCase {cantSimplify, cases, default, gone, test: VarInfo.t}
+ and simplifyCase {canMove, cantSimplify,
+ cases, default, gone, test: VarInfo.t}
: Statement.t list * Transfer.t =
let
(* tryToEliminate makes sure that the destination meaning
@@ -927,7 +956,7 @@
val () = addLabelIndex i
val () = gone ()
in
- gotoMeaning (m, Vector.new0 ())
+ gotoMeaning (canMove, m, Vector.new0 ())
end
end
in
@@ -960,7 +989,7 @@
val () = addLabelMeaning m
val () = gone ()
in
- gotoMeaning (m, args)
+ gotoMeaning (canMove, m, args)
end
fun loop k =
if k = n
@@ -1010,10 +1039,11 @@
end
and goto (dst: Label.t, args: VarInfo.t vector)
: Statement.t list * Transfer.t =
- gotoMeaning (labelMeaning dst, args)
+ gotoMeaning ([], labelMeaning dst, args)
and gotoMeaning arg : Statement.t list * Transfer.t =
traceGotoMeaning
- (fn (m as LabelMeaning.T {aux, blockIndex = i, ...},
+ (fn (canMoveIn,
+ m as LabelMeaning.T {aux, blockIndex = i, ...},
args: VarInfo.t vector) =>
let
val n = Array.sub (inDegree, i)
@@ -1029,13 +1059,13 @@
(Block.args b, args, fn ((x, _), vi) =>
setVarInfo (x, vi))
in
- simplifyBlock b
+ simplifyBlock (canMoveIn, b)
end
else
let
val () = forceMeaningBlock m
in
- ([],
+ (canMoveIn,
Goto {dst = Block.label (Vector.sub (blocks, i)),
args = uses args})
end
@@ -1044,19 +1074,21 @@
Position.Formal n => Vector.sub (args, n)
| Position.Free x => varInfo x
fun rr ({args, canMove}, make) =
- (canMove, make (Vector.map (args, use o extract)))
+ (canMoveIn @ canMove,
+ make (Vector.map (args, use o extract)))
datatype z = datatype LabelMeaning.aux
in
case aux of
Block => normal ()
- | Bug => ([], Transfer.Bug)
- | Case {cases, default} =>
- simplifyCase {cantSimplify = normal,
+ | Bug => ((*canMoveIn*)[], Transfer.Bug)
+ | Case {canMove, cases, default} =>
+ simplifyCase {canMove = canMoveIn @ canMove,
+ cantSimplify = normal,
cases = cases,
default = default,
gone = fn () => deleteLabelMeaning m,
test = Vector.sub (args, 0)}
- | Goto {dst, args} =>
+ | Goto {canMove, dst, args} =>
if Array.sub (isHeader, i)
orelse Array.sub (isBlock, i)
then normal ()
@@ -1069,7 +1101,9 @@
then addLabelMeaning dst
else ()
in
- gotoMeaning (dst, Vector.map (args, extract))
+ gotoMeaning (canMoveIn @ canMove,
+ dst,
+ Vector.map (args, extract))
end
| Raise z => rr (z, Transfer.Raise)
| Return z => rr (z, Transfer.Return)