[MLton] cvs commit: Added -inline-into-main {true|false}.

Stephen Weeks sweeks@mlton.org
Wed, 2 Jun 2004 17:17:25 -0700


sweeks      04/06/02 17:17:23

  Modified:    mlton/control control.sig control.sml
               mlton/main main.fun
               mlton/ssa contify.fun inline.fun ssa-tree.fun ssa-tree.sig
  Log:
  MAIL Added -inline-into-main {true|false}.
  
  This flag controls whether the SSA inliner will inline functions into
  the main function.  The idea was to use -inline-into-main false to
  keep the size of main down.  Unfortunately, it doesn't work well,
  because some stuff like determining the platform relies on some small
  functions getting inlined into main.  This causes very basic constants
  that one would expect to get folded away not to be.
  
  I'll probably remove this flag soon since it's so useless.  This
  checkin is mainly for documentation of a failed attempt.

Revision  Changes    Path
1.100     +2 -0      mlton/mlton/control/control.sig

Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.99
retrieving revision 1.100
diff -u -r1.99 -r1.100
--- control.sig	2 Jun 2004 17:36:43 -0000	1.99
+++ control.sig	3 Jun 2004 00:17:21 -0000	1.100
@@ -97,6 +97,8 @@
       val layoutInline: inline -> Layout.t
       val setInlineSize: int -> unit
 
+      val inlineIntoMain: bool ref
+
       (* The input file on the command line, minus path and extension *)
       val inputFile: File.t ref
 



1.124     +4 -0      mlton/mlton/control/control.sml

Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.123
retrieving revision 1.124
diff -u -r1.123 -r1.124
--- control.sml	2 Jun 2004 17:36:43 -0000	1.123
+++ control.sml	3 Jun 2004 00:17:21 -0000	1.124
@@ -212,6 +212,10 @@
 	       | Leaf _ => Leaf {size = SOME size}
 	       | LeafNoLoop _ => LeafNoLoop {size = SOME size})
 
+val inlineIntoMain = control {name = "inlintIntoMain",
+			      default = true,
+			      toString = Bool.toString}
+
 val inputFile = control {name = "input file",
 			 default = "<bogus>",
 			 toString = File.toString}



1.40      +3 -0      mlton/mlton/main/main.fun

Index: main.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.fun,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -r1.39 -r1.40
--- main.fun	2 Jun 2004 17:36:44 -0000	1.39
+++ main.fun	3 Jun 2004 00:17:22 -0000	1.40
@@ -215,6 +215,9 @@
        (Expert, "indentation", " <n>", "indentation level in ILs",
 	intRef indentation),
        (Normal, "inline", " <n>", "set inlining threshold", Int setInlineSize),
+       (Expert, "inline-into-main", " {true|false}",
+	"inline functions into main",
+	boolRef inlineIntoMain),
        (Normal, "keep", " {g|o|sml}", "save intermediate files",
 	SpaceString (fn s =>
 		     case s of



1.19      +12 -15    mlton/mlton/ssa/contify.fun

Index: contify.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/contify.fun,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- contify.fun	2 Jun 2004 17:36:44 -0000	1.18
+++ contify.fun	3 Jun 2004 00:17:23 -0000	1.19
@@ -330,7 +330,7 @@
      *                forall c in Cont. (ContData.node o getContData) c = NONE
      *                forall f in Func. (FuncData.node o getFuncData) f = NONE
      *)
-    fun analyzeDom {program = Program.T {functions, main = fm, ...},
+    fun analyzeDom {program as Program.T {functions, main = fm, ...},
 		    getContData: Cont.t -> ContData.t,
 		    getFuncData: Func.t -> FuncData.t} : unit
       = let
@@ -350,20 +350,17 @@
 	     if !Control.contifyIntoMain
 		then ()
 	     else
-		case List.peek (functions, fn f =>
-				Func.equals (fm, Function.name f)) of
-		   NONE => Error.bug "no main function"
-		 | SOME f =>
-		      let
-			 val {blocks, ...} = Function.dest f
-		      in
-			 Vector.foreach
-			 (blocks, fn Block.T {transfer, ...} =>
-			  case transfer of
-			     Call {func, ...} =>
-				addEdge {from = Root, to = getFuncNode func}
-			   | _ => ())
-		      end
+		let
+		   val {blocks, ...} =
+		      Function.dest (Program.mainFunction program)
+		in
+		   Vector.foreach
+		   (blocks, fn Block.T {transfer, ...} =>
+		    case transfer of
+		       Call {func, ...} =>
+			  addEdge {from = Root, to = getFuncNode func}
+		     | _ => ())
+		end
 	  val _
 	    = List.foreach
 	      (functions,



1.20      +43 -21    mlton/mlton/ssa/inline.fun

Index: inline.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/inline.fun,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- inline.fun	18 Mar 2004 03:22:25 -0000	1.19
+++ inline.fun	3 Jun 2004 00:17:23 -0000	1.20
@@ -1,10 +1,11 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
  * MLton is released under the GNU General Public License (GPL).
  * Please see the file MLton-LICENSE for license information.
  *)
+
 functor Inline (S: INLINE_STRUCTS): INLINE = 
 struct
 
@@ -294,19 +295,30 @@
 	  | Leaf r => leaf (program, r)
 	  | LeafNoLoop r => leafNoLoop (program, r)
 	 end
-      val {get = funcInfo: Func.t -> Function.t,
+      val {get = funcInfo: Func.t -> {function: Function.t,
+				      isCalledByMain: bool ref},
 	   set = setFuncInfo, ...} =
 	 Property.getSetOnce
 	 (Func.plist, Property.initRaise ("Inline.funcInfo", Func.layout))
-      val _ = List.foreach (functions, fn f => setFuncInfo (Function.name f, f))
-
+      val () = List.foreach (functions, fn f =>
+			     setFuncInfo (Function.name f,
+					  {function = f,
+					   isCalledByMain = ref false}))
+      val () =
+	 Vector.foreach (#blocks (Function.dest (Program.mainFunction program)),
+			 fn Block.T {transfer, ...} =>
+			 case transfer of
+			    Transfer.Call {func, ...} =>
+			       #isCalledByMain (funcInfo func) := true
+			  | _ => ())
       fun doit (blocks: Block.t vector,
 		return: Return.t) : Block.t vector =
 	 let
 	    val newBlocks = ref []
 	    val blocks =
 	       Vector.map
-	       (blocks, fn block as Block.T {label, args, statements, transfer} =>
+	       (blocks,
+		fn block as Block.T {label, args, statements, transfer} =>
 		let
 		   fun new transfer =
 		      Block.T {label = label,
@@ -325,7 +337,7 @@
 				 local
 				    val {name, args, start, blocks, ...} =
 				       (Function.dest o Function.alphaRename) 
-				       (funcInfo func)
+				       (#function (funcInfo func))
 				    val blocks = doit (blocks, return)
 				    val _ = List.push (newBlocks, blocks)
 				    val name =
@@ -368,28 +380,38 @@
 	 in
 	    Vector.concat (blocks::(!newBlocks))
 	 end
-
-      val shrink = shrinkFunction globals 
+      val shrink = shrinkFunction globals
+      val inlineIntoMain = !Control.inlineIntoMain
       val functions =
 	 List.fold
 	 (functions, [], fn (f, ac) =>
 	  let
 	     val {args, blocks, name, raises, returns, start} = Function.dest f
+	     fun keep () =
+		let
+		   val blocks = doit (blocks, Return.Tail)
+		in
+		   shrink (Function.new {args = args,
+					 blocks = blocks,
+					 name = name,
+					 raises = raises,
+					 returns = returns,
+					 start = start})
+		   :: ac
+		end
 	  in
 	     if Func.equals (name, main)
-	        orelse not (shouldInline name)
-		then let
-		        val blocks = doit (blocks, Return.Tail)
-		     in
-			shrink (Function.new {args = args,
-					      blocks = blocks,
-					      name = name,
-					      raises = raises,
-					      returns = returns,
-					      start = start})
-			:: ac
-		     end
-	      else ac
+		then if inlineIntoMain
+			then keep ()
+		     else f :: ac
+	     else
+		if shouldInline name
+		   then
+		      if inlineIntoMain
+			 orelse not (! (#isCalledByMain (funcInfo name)))
+			 then ac
+		      else keep ()
+		else keep ()
 	  end)
       val program =
 	 Program.T {datatypes = datatypes,



1.72      +6 -0      mlton/mlton/ssa/ssa-tree.fun

Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.71
retrieving revision 1.72
diff -u -r1.71 -r1.72
--- ssa-tree.fun	2 Jun 2004 16:57:39 -0000	1.71
+++ ssa-tree.fun	3 Jun 2004 00:17:23 -0000	1.72
@@ -1713,6 +1713,12 @@
 	  (foreachPrim (p, fn prim => if f prim then escape true else ())
 	   ; false))
 
+      fun mainFunction (T {functions, main, ...}) =
+	 case List.peek (functions, fn f =>
+			 Func.equals (main, Function.name f)) of
+	    NONE => Error.bug "no main function"
+	  | SOME f => f
+
       fun profile (T {datatypes, functions, globals, main}) =
 	 let
 	    val functions =



1.58      +1 -0      mlton/mlton/ssa/ssa-tree.sig

Index: ssa-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.sig,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -r1.57 -r1.58
--- ssa-tree.sig	1 May 2004 00:49:47 -0000	1.57
+++ ssa-tree.sig	3 Jun 2004 00:17:23 -0000	1.58
@@ -257,6 +257,7 @@
 	    val hasPrim: t * (Type.t Prim.t -> bool) -> bool
 	    val layouts: t * (Layout.t -> unit) -> unit
 	    val layoutStats: t -> Layout.t
+	    val mainFunction: t -> Function.t
 	    val profile: t -> t
 	 end
    end