[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