[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)