[MLton] cvs commit: fixed quadratic liveness for list constants

[Stephen Weeks]

sweeks      04/06/29 22:27:05

  Modified:    mlton/defunctorize defunctorize.fun
  Log:
  MAIL fixed quadratic liveness for list constants
  
  Fixed a performance problem that caused a quadratic amount of liveness
  information for list constants.  The problem is that list elements are
  evaluated left-to-right, but lists are constructed right-to-left.  So,
  for [e1, e2, ..., en], the code looks like
  
   	x1 = e1
          x2 = e2
          ...
          xn = en
          x1 :: (x2 :: ... :: (xn :: []))
  
  Note that at each ei, all of the previous xi are live.  Hence, if each
  ei is a complex expression that cause the creation of a new basic
  block, there will be a quadratic amount of liveness information.
  
  The fix is to build the list in reverse as we go, and then reverse it
  at the end.
  
  	l0 = []
  	l1 = e1 :: l0
  	l2 = e2 :: l1
  	...
  	ln = en :: l(n-1)
  	rev ln
  
  With this approach, there is a constant number of live variables at
  each block.
  
  For now, I've hardwired in a constant, 20, so that lists larger than
  that use the reverse trick, and smaller lists are evaluated directly.
  
  This fix didn't help with the HOL performance problem, which is due to
  the large number of blocks in main.

Revision  Changes    Path
1.18      +109 -21   mlton/mlton/defunctorize/defunctorize.fun

Index: defunctorize.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/defunctorize/defunctorize.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- defunctorize.fun	1 May 2004 00:49:41 -0000	1.17
+++ defunctorize.fun	30 Jun 2004 05:27:02 -0000	1.18
@@ -322,6 +322,114 @@
 				    tyvars = tyvars,
 				    var = x}]}
 
+structure Xexp =
+   struct
+      open Xexp
+	 
+      val list: Xexp.t vector * Xtype.t -> Xexp.t =
+	 fn (es, ty) =>
+	 let
+	    val targs = #2 (valOf (Xtype.deConOpt ty))
+	    val eltTy = Vector.sub (targs, 0)
+	    val nill: Xexp.t =
+	       Xexp.conApp {arg = NONE,
+			    con = Con.nill,
+			    targs = targs,
+			    ty = ty}
+	    val consArgTy = Xtype.tuple (Vector.new2 (eltTy, ty))
+	    val cons: Xexp.t * Xexp.t -> Xexp.t =
+	       fn (e1, e2) =>
+	       Xexp.conApp
+	       {arg = SOME (Xexp.tuple {exps = Vector.new2 (e1, e2),
+					ty = consArgTy}),
+		con = Con.cons,
+		targs = targs,
+		ty = ty}
+	 in
+	    if Vector.length es < 20
+	       then Vector.foldr (es, nill, cons)
+	    else
+	       let
+		  val revArgTy = Xtype.tuple (Vector.new2 (ty, ty))
+		  val revTy = Xtype.arrow (revArgTy, ty)
+		  val revVar = Var.newString "rev"
+		  fun rev (e1, e2) =
+		     Xexp.app
+		     {func = Xexp.monoVar (revVar, revTy),
+		      arg = Xexp.tuple {exps = Vector.new2 (e1, e2),
+					ty = revArgTy},
+		      ty = ty}
+		  fun detuple2 (tuple: Xexp.t,
+				f: XvarExp.t * XvarExp.t -> Xexp.t): Xexp.t =
+		     Xexp.detuple {body = fn xs => let
+						      fun x i = #1 (Vector.sub (xs, i))
+						   in
+						      f (x 0, x 1)
+						   end,
+						tuple = tuple}
+		  val revArg = Var.newNoname ()
+		  val revLambda =
+		     Xlambda.make
+		     {arg = revArg,
+		      argType = revArgTy,
+		      body =
+		      Xexp.toExp
+		      (detuple2
+		       (Xexp.monoVar (revArg, revArgTy), fn (l, ac) =>
+			let
+			   val ac = Xexp.varExp (ac, ty)
+			   val consArg = Var.newNoname ()
+			in
+			   Xexp.casee
+			   {cases =
+			    Xcases.Con
+			    (Vector.new2
+			     ((Xpat.T {arg = NONE,
+				       con = Con.nill,
+				       targs = targs},
+			       ac),
+			      (Xpat.T {arg = SOME (consArg, consArgTy),
+				       con = Con.cons,
+				       targs = targs},
+			       detuple2
+			       (Xexp.monoVar (consArg, consArgTy),
+				fn (x, l) =>
+				rev (Xexp.varExp (l, ty),
+				     cons (Xexp.varExp (x, eltTy),
+					   ac)))))),
+			    default = NONE,
+			    test = Xexp.varExp (l, ty),
+			    ty = ty}
+			end))}
+		  val revDec =
+		     Xdec.Fun
+		     {decs = Vector.new1 {lambda = revLambda,
+					  ty = revTy,
+					  var = revVar},
+		      tyvars = Vector.new0 ()}
+		  val l = Var.newNoname ()
+		  val (l, body) =
+		     Vector.foldr
+		     (es, (l, Xexp.lett {decs = [revDec],
+					 body = rev (Xexp.monoVar (l, ty),
+						     nill)}),
+		      fn (e, (l, body)) =>
+		      let
+			 val l' = Var.newNoname ()
+		      in
+			 (l',
+			  Xexp.let1 {body = body,
+				     exp = cons (e, Xexp.monoVar (l', ty)),
+				     var = l})
+		      end)
+	       in
+		  Xexp.let1 {body = body,
+			     exp = nill,
+			     var = l}
+	       end
+	 end
+   end
+
 fun defunctorize (CoreML.Program.T {decs}) =
    let
       val {get = conExtraArgs: Con.t -> Xtype.t vector option,
@@ -782,27 +890,7 @@
 				   ty = ty}
 		| Lambda l => Xexp.lambda (loopLambda l)
 		| Let (ds, e) => loopDecs (ds, loopExp e)
-		| List es =>
-		     let
-			val targs = #2 (valOf (Xtype.deConOpt ty))
-			val eltTy = Vector.sub (targs, 0)
-		     in
-			Vector.foldr
-			(es,
-			 Xexp.conApp {arg = NONE,
-				      con = Con.nill,
-				      targs = targs,
-				      ty = ty},
-			 fn (e, l) =>
-			 Xexp.conApp
-			 {arg = (SOME
-				 (Xexp.tuple
-				  {exps = Vector.new2 (#1 (loopExp e), l),
-				   ty = Xtype.tuple (Vector.new2 (eltTy, ty))})),
-			  con = Con.cons,
-			  targs = targs,
-			  ty = ty})
-		     end
+		| List es => Xexp.list (Vector.map (es, #1 o loopExp), ty)
 		| PrimApp {args, prim, targs} =>
 		     let
 			val args = Vector.map (args, #1 o loopExp)