[MLton-commit] r5791
Matthew Fluet
fluet at mlton.org
Wed Jul 25 20:46:32 PDT 2007
Additional leaf inlining functionality
----------------------------------------------------------------------
U mlton/trunk/mlton/control/control-flags.sig
U mlton/trunk/mlton/control/control-flags.sml
U mlton/trunk/mlton/main/main.fun
U mlton/trunk/mlton/ssa/inline.fun
U mlton/trunk/mlton/ssa/inline.sig
U mlton/trunk/mlton/ssa/simplify.fun
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/control/control-flags.sig
===================================================================
--- mlton/trunk/mlton/control/control-flags.sig 2007-07-25 23:04:09 UTC (rev 5790)
+++ mlton/trunk/mlton/control/control-flags.sig 2007-07-26 03:46:30 UTC (rev 5791)
@@ -151,14 +151,12 @@
(* Indentation used in laying out ILs. *)
val indentation: int ref
- datatype inline =
- NonRecursive of {product: int,
- small: int}
- | Leaf of {size: int option}
- | LeafNoLoop of {size: int option}
- val inline: inline ref
- val setInlineSize: int -> unit
+ val inline: int ref
+ val inlineLeafSize: int option ref
+ val inlineLeafLoops: bool ref
+ val inlineLeafRepeat: bool ref
+
val inlineIntoMain: bool ref
(* The input file on the command line, minus path and extension. *)
Modified: mlton/trunk/mlton/control/control-flags.sml
===================================================================
--- mlton/trunk/mlton/control/control-flags.sml 2007-07-25 23:04:09 UTC (rev 5790)
+++ mlton/trunk/mlton/control/control-flags.sml 2007-07-26 03:46:30 UTC (rev 5791)
@@ -653,42 +653,22 @@
default = 3,
toString = Int.toString}
-structure Inline =
- struct
- datatype t =
- NonRecursive of {product: int,
- small: int}
- | Leaf of {size: int option}
- | LeafNoLoop of {size: int option}
+val inline = control {name = "inline",
+ default = 60,
+ toString = Int.toString}
- local open Layout
- val iol = Option.layout Int.layout
- in
- val layout =
- fn NonRecursive {product, small} =>
- seq [str "NonRecursive ",
- record [("product", Int.layout product),
- ("small", Int.layout small)]]
- | Leaf {size} => seq [str "Leaf ", iol size]
- | LeafNoLoop {size} => seq [str "LeafNoLoop ", iol size]
- end
- val toString = Layout.toString o layout
- end
+val inlineLeafLoops = control {name = "inlineLeafLoops",
+ default = true,
+ toString = Bool.toString}
-datatype inline = datatype Inline.t
+val inlineLeafRepeat = control {name = "inlineLeafRepeat",
+ default = false,
+ toString = Bool.toString}
-val inline = control {name = "inline",
- default = NonRecursive {product = 320,
- small = 60},
- toString = Inline.toString}
+val inlineLeafSize = control {name = "inlineLeafSize",
+ default = SOME 20,
+ toString = Option.toString Int.toString}
-fun setInlineSize (size: int): unit =
- inline := (case !inline of
- NonRecursive {small, ...} =>
- NonRecursive {product = size, small = small}
- | Leaf _ => Leaf {size = SOME size}
- | LeafNoLoop _ => LeafNoLoop {size = SOME size})
-
val inlineIntoMain = control {name = "inlineIntoMain",
default = true,
toString = Bool.toString}
Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun 2007-07-25 23:04:09 UTC (rev 5790)
+++ mlton/trunk/mlton/main/main.fun 2007-07-26 03:46:30 UTC (rev 5791)
@@ -340,10 +340,23 @@
boolRef Native.IEEEFP),
(Expert, "indentation", " <n>", "indentation level in ILs",
intRef indentation),
- (Normal, "inline", " <n>", "set inlining threshold", Int setInlineSize),
+ (Normal, "inline", " <n>", "set inlining threshold", intRef inline),
(Expert, "inline-into-main", " {true|false}",
"inline functions into main",
boolRef inlineIntoMain),
+ (Expert, "inline-leaf-size", " 20", "set leaf inlining threshold",
+ SpaceString (fn s =>
+ inlineLeafSize :=
+ (if s = "inf"
+ then NONE
+ else if String.forall (s, Char.isDigit)
+ then Int.fromString s
+ else (usage o concat)
+ ["invalid -inline-leaf-size flag: ", s]))),
+ (Expert, "inline-leaf-loops", " {true|false}", " leaf inline loops",
+ boolRef inlineLeafLoops),
+ (Expert, "inline-leaf-repeat", " {false|true}", " repeat leaf inline",
+ boolRef inlineLeafRepeat),
(Normal, "keep", " {g|o|sml}", "save intermediate files",
SpaceString (fn s =>
case s of
Modified: mlton/trunk/mlton/ssa/inline.fun
===================================================================
--- mlton/trunk/mlton/ssa/inline.fun 2007-07-25 23:04:09 UTC (rev 5790)
+++ mlton/trunk/mlton/ssa/inline.fun 2007-07-26 03:46:30 UTC (rev 5791)
@@ -14,6 +14,42 @@
type int = Int.t
+structure Function =
+ struct
+ open Function
+
+ fun containsCall (f: Function.t): bool =
+ Exn.withEscape
+ (fn escape =>
+ (Vector.foreach
+ (Function.blocks f, fn Block.T {transfer, ...} =>
+ case transfer of
+ Call _ => escape true
+ | _ => ())
+ ; false))
+ fun containsLoop (f: Function.t): bool =
+ let
+ val {get, set, destroy} =
+ Property.destGetSet (Label.plist, Property.initConst false)
+ in
+ Exn.withEscape
+ (fn escape =>
+ let
+ val _ =
+ Function.dfs
+ (f, fn (Block.T {label, transfer, ...}) =>
+ (set (label, true)
+ ; (case transfer of
+ Goto {dst, ...} => if get dst then escape true else ()
+ | _ => ())
+ ; fn () => set (label, false)))
+ in
+ false
+ end)
+ before (destroy ())
+ end
+ end
+
structure Size =
struct
val check : (int * int option) -> bool =
@@ -110,50 +146,138 @@
end)
; shouldInline
end
- fun containsCall (f: Function.t): bool =
- Exn.withEscape
- (fn escape =>
- (Vector.foreach
- (Function.blocks f, fn Block.T {transfer, ...} =>
- case transfer of
- Call _ => escape true
- | _ => ())
- ; false))
- fun containsLoop (f: Function.t): bool =
+in
+ val leafOnce = make (fn (f, {size}) =>
+ Size.functionGT size f
+ orelse Function.containsCall f)
+ val leafOnceNoLoop = make (fn (f, {size}) =>
+ Size.functionGT size f
+ orelse Function.containsCall f
+ orelse Function.containsLoop f)
+end
+
+structure Graph = DirectedGraph
+structure Node = Graph.Node
+
+local
+ fun make (dontInline: Function.t -> bool)
+ (Program.T {functions, ...}, {size: int option}) =
let
- val {get, set, destroy} =
- Property.destGetSet (Label.plist, Property.initConst false)
+ val max = size
+ type info = {function: Function.t,
+ node: unit Node.t,
+ shouldInline: bool ref,
+ size: int ref}
+ val {get = funcInfo: Func.t -> info,
+ set = setFuncInfo, ...} =
+ Property.getSetOnce
+ (Func.plist, Property.initRaise ("funcInfo", Func.layout))
+ val {get = nodeFunc: unit Node.t -> Func.t,
+ set = setNodeFunc, ...} =
+ Property.getSetOnce
+ (Node.plist, Property.initRaise ("nodeFunc", Node.layout))
+ val graph = Graph.new ()
+ (* initialize the info for each func *)
+ val _ =
+ List.foreach
+ (functions, fn f =>
+ let
+ val name = Function.name f
+ val n = Graph.newNode graph
+ in
+ setNodeFunc (n, name)
+ ; setFuncInfo (name, {function = f,
+ node = n,
+ shouldInline = ref false,
+ size = ref 0})
+ end)
+ (* Build the call graph. *)
+ val _ =
+ List.foreach
+ (functions, fn f =>
+ let
+ val {name, blocks, ...} = Function.dest f
+ val {node, ...} = funcInfo name
+ in
+ Vector.foreach
+ (blocks, fn Block.T {transfer, ...} =>
+ case transfer of
+ Call {func, ...} =>
+ (ignore o Graph.addEdge)
+ (graph, {from = node, to = #node (funcInfo func)})
+ | _ => ())
+ end)
+ (* Compute strongly-connected components.
+ * Then start at the leaves of the call graph and work up.
+ *)
+ val _ =
+ List.foreach
+ (rev (Graph.stronglyConnectedComponents graph),
+ fn scc =>
+ case scc of
+ [n] =>
+ let
+ val {function, shouldInline, size, ...} =
+ funcInfo (nodeFunc n)
+ in
+ if Function.mayInline function
+ andalso not (dontInline function)
+ then Exn.withEscape
+ (fn escape =>
+ let
+ val (n, check) =
+ Size.functionSize
+ (0, max)
+ (Size.defaultExpSize,
+ fn t =>
+ case t of
+ Call {func, ...} =>
+ let
+ val {shouldInline, size, ...} =
+ funcInfo func
+ in
+ if !shouldInline
+ then !size
+ else escape ()
+ end
+ | _ => Size.defaultTransferSize t)
+ function
+ in
+ if check
+ then ()
+ else (shouldInline := true
+ ; size := n)
+ end)
+ else ()
+ end
+ | _ => ())
+ val _ =
+ Control.diagnostics
+ (fn display =>
+ let open Layout
+ in List.foreach
+ (functions, fn f =>
+ let
+ val name = Function.name f
+ val {shouldInline, size, ...} = funcInfo name
+ val shouldInline = !shouldInline
+ val size = !size
+ in
+ display
+ (seq [Func.layout name, str ": ",
+ record [("shouldInline", Bool.layout shouldInline),
+ ("size", Int.layout size)]])
+ end)
+ end)
in
- Exn.withEscape
- (fn escape =>
- let
- val _ =
- Function.dfs
- (f, fn (Block.T {label, transfer, ...}) =>
- (set (label, true)
- ; (case transfer of
- Goto {dst, ...} => if get dst then escape true else ()
- | _ => ())
- ; fn () => set (label, false)))
- in
- false
- end)
- before (destroy ())
+ ! o #shouldInline o funcInfo
end
in
- val leaf = make (fn (f, {size}) =>
- Size.functionGT size f
- orelse containsCall f)
- val leafNoLoop = make (fn (f, {size}) =>
- Size.functionGT size f
- orelse containsCall f
- orelse containsLoop f)
+ val leafRepeat = make (fn _ => false)
+ val leafRepeatNoLoop = make (fn f => Function.containsLoop f)
end
-structure Graph = DirectedGraph
-structure Node = Graph.Node
-
-fun product (Program.T {functions, ...}, {small: int, product: int}) =
+fun nonRecursive (Program.T {functions, ...}, {small: int, product: int}) =
let
type info = {doesCallSelf: bool ref,
function: Function.t,
@@ -280,39 +404,37 @@
display
(seq [Func.layout name, str ": ",
record [("numCalls", Int.layout numCalls),
- ("size", Int.layout size),
- ("shouldInline", Bool.layout shouldInline)]])
+ ("shouldInline", Bool.layout shouldInline),
+ ("size", Int.layout size)]])
end)
end)
in
! o #shouldInline o funcInfo
end
-fun inline (program as Program.T {datatypes, globals, functions, main}) =
+fun transform {program as Program.T {datatypes, globals, functions, main},
+ shouldInline: Func.t -> bool,
+ inlineIntoMain: bool} =
let
- val shouldInline: Func.t -> bool =
- let open Control
- in case !inline of
- NonRecursive r => product (program, r)
- | Leaf r => leaf (program, r)
- | LeafNoLoop r => leafNoLoop (program, r)
- end
val {get = funcInfo: Func.t -> {function: Function.t,
isCalledByMain: bool ref},
set = setFuncInfo, ...} =
Property.getSetOnce
(Func.plist, Property.initRaise ("Inline.funcInfo", Func.layout))
+ val isCalledByMain: Func.t -> bool =
+ ! o #isCalledByMain o funcInfo
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
- | _ => ())
+ 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
@@ -383,7 +505,6 @@
Vector.concat (blocks::(!newBlocks))
end
val shrink = shrinkFunction {globals = globals}
- val inlineIntoMain = !Control.inlineIntoMain
val functions =
List.fold
(functions, [], fn (f, ac) =>
@@ -412,7 +533,7 @@
if shouldInline name
then
if inlineIntoMain
- orelse not (! (#isCalledByMain (funcInfo name)))
+ orelse not (isCalledByMain name)
then ac
else keep ()
else keep ()
@@ -427,4 +548,39 @@
program
end
+fun inlineLeafOnce (p, {size}) =
+ if size = SOME 0
+ then p
+ else transform {program = p,
+ shouldInline = leafOnce (p, {size = size}),
+ inlineIntoMain = true}
+fun inlineLeafOnceNoLoop (p, {size}) =
+ if size = SOME 0
+ then p
+ else transform {program = p,
+ shouldInline = leafOnceNoLoop (p, {size = size}),
+ inlineIntoMain = true}
+fun inlineLeafRepeat (p, {size}) =
+ if size = SOME 0
+ then p
+ else transform {program = p,
+ shouldInline = leafRepeat (p, {size = size}),
+ inlineIntoMain = true}
+fun inlineLeafRepeatNoLoop (p, {size}) =
+ if size = SOME 0
+ then p
+ else transform {program = p,
+ shouldInline = leafRepeatNoLoop (p, {size = size}),
+ inlineIntoMain = true}
+fun inlineLeaf (p, {loops, repeat, size}) =
+ case (loops, repeat) of
+ (false, false) => inlineLeafOnce (p, {size = size})
+ | (false, true) => inlineLeafRepeat (p, {size = size})
+ | (true, false) => inlineLeafOnceNoLoop (p, {size = size})
+ | (true, true) => inlineLeafRepeatNoLoop (p, {size = size})
+fun inlineNonRecursive (p, arg) =
+ transform {program = p,
+ shouldInline = nonRecursive (p, arg),
+ inlineIntoMain = !Control.inlineIntoMain}
+
end
Modified: mlton/trunk/mlton/ssa/inline.sig
===================================================================
--- mlton/trunk/mlton/ssa/inline.sig 2007-07-25 23:04:09 UTC (rev 5790)
+++ mlton/trunk/mlton/ssa/inline.sig 2007-07-26 03:46:30 UTC (rev 5791)
@@ -6,6 +6,8 @@
* See the file MLton-LICENSE for details.
*)
+type int = Int.t
+
signature INLINE_STRUCTS =
sig
include SHRINK
@@ -15,5 +17,12 @@
sig
include INLINE_STRUCTS
- val inline: Program.t -> Program.t
+ val inlineLeaf:
+ Program.t * {loops: bool, repeat: bool, size: int option} -> Program.t
+ val inlineLeafOnce: Program.t * {size:int option} -> Program.t
+ val inlineLeafOnceNoLoop: Program.t * {size:int option} -> Program.t
+ val inlineLeafRepeat: Program.t * {size:int option} -> Program.t
+ val inlineLeafRepeatNoLoop: Program.t * {size:int option} -> Program.t
+
+ val inlineNonRecursive: Program.t * {small:int,product:int} -> Program.t
end
Modified: mlton/trunk/mlton/ssa/simplify.fun
===================================================================
--- mlton/trunk/mlton/ssa/simplify.fun 2007-07-25 23:04:09 UTC (rev 5790)
+++ mlton/trunk/mlton/ssa/simplify.fun 2007-07-26 03:46:30 UTC (rev 5791)
@@ -31,30 +31,16 @@
structure SimplifyTypes = SimplifyTypes (S)
structure Useless = Useless (S)
-fun inlineNonRecursive (product, small) p =
- Ref.fluidLet
- (Control.inline,
- Control.NonRecursive {product = product, small = small},
- fn () => Inline.inline p)
-fun inlineLeaf size p =
- Ref.fluidLet
- (Control.inlineIntoMain, true, fn () =>
- Ref.fluidLet
- (Control.inline, Control.Leaf {size = SOME size},
- fn () => Inline.inline p))
-fun inlineLeafNoLoop size p =
- Ref.fluidLet
- (Control.inlineIntoMain, true, fn () =>
- Ref.fluidLet
- (Control.inline, Control.LeafNoLoop {size = SOME size},
- fn () => Inline.inline p))
-
type pass = {name: string,
doit: Program.t -> Program.t}
val ssaPassesDefault =
{name = "removeUnused1", doit = RemoveUnused.remove} ::
- {name = "leafInline", doit = inlineLeaf 20} ::
+ {name = "introduceLoops1", doit = IntroduceLoops.introduceLoops} ::
+ {name = "inlineLeaf", doit = fn p =>
+ Inline.inlineLeaf (p, {loops = !Control.inlineLeafLoops,
+ repeat = !Control.inlineLeafRepeat,
+ size = !Control.inlineLeafSize})} ::
{name = "contify1", doit = Contify.contify} ::
{name = "localFlatten1", doit = LocalFlatten.flatten} ::
{name = "constantPropagation", doit = ConstantPropagation.simplify} ::
@@ -71,11 +57,12 @@
*)
{name = "polyEqual", doit = PolyEqual.polyEqual} ::
{name = "contify2", doit = Contify.contify} ::
- {name = "inline", doit = Inline.inline} ::
+ {name = "inlineNonRecursive", doit = fn p =>
+ Inline.inlineNonRecursive (p, {small = !Control.inline, product = 320})} ::
{name = "localFlatten2", doit = LocalFlatten.flatten} ::
{name = "removeUnused3", doit = RemoveUnused.remove} ::
{name = "contify3", doit = Contify.contify} ::
- {name = "introduceLoops", doit = IntroduceLoops.introduceLoops} ::
+ {name = "introduceLoops2", doit = IntroduceLoops.introduceLoops} ::
{name = "loopInvariant", doit = LoopInvariant.loopInvariant} ::
{name = "localRef", doit = LocalRef.eliminate} ::
{name = "flatten", doit = Flatten.flatten} ::
@@ -114,22 +101,30 @@
let
val count = Counter.new 1
fun nums s =
- if s = ""
- then SOME []
- else if String.sub (s, 0) = #"("
- andalso String.sub (s, String.size s - 1)= #")"
- then let
- val s = String.dropFirst (String.dropLast s)
- in
- case List.fold (String.split (s, #","), SOME [],
- fn (s,SOME nums) => (case Int.fromString s of
- SOME i => SOME (i::nums)
- | NONE => NONE)
- | (_, NONE) => NONE) of
- SOME (l as _::_) => SOME (List.rev l)
- | _ => NONE
- end
- else NONE
+ Exn.withEscape
+ (fn escape =>
+ if s = ""
+ then SOME []
+ else let
+ val l = String.length s
+ in
+ if String.sub (s, 0) = #"("
+ andalso String.sub (s, l - 1)= #")"
+ then let
+ val s = String.substring2 (s, {start = 1, finish = l - 1})
+ fun doit s =
+ if s = "inf"
+ then NONE
+ else if String.forall (s, Char.isDigit)
+ then Int.fromString s
+ else escape NONE
+ in
+ case List.map (String.split (s, #","), doit) of
+ l as _::_ => SOME l
+ | _ => NONE
+ end
+ else NONE
+ end)
in
fn s =>
if String.hasPrefix (s, {prefix = "inlineNonRecursive"})
@@ -139,42 +134,80 @@
Int.toString product, ",",
Int.toString small, ")#",
Int.toString (Counter.next count)],
- doit = inlineNonRecursive (product, small)}
+ doit = (fn p =>
+ Inline.inlineNonRecursive
+ (p, {small = small, product = product}))}
val s = String.dropPrefix (s, String.size "inlineNonRecursive")
in
case nums s of
SOME [] => mk (320, 60)
- | SOME [product, small] => mk (product, small)
+ | SOME [SOME product, SOME small] => mk (product, small)
| _ => NONE
end
- else if String.hasPrefix (s, {prefix = "inlineLeafNoLoop"})
+ else if String.hasPrefix (s, {prefix = "inlineLeafRepeat"})
then let
fun mk size =
- SOME {name = concat ["inlineLeafNoLoop(",
- Int.toString size, ")#",
+ SOME {name = concat ["inlineLeafRepeat(",
+ Option.toString Int.toString size, ")#",
Int.toString (Counter.next count)],
- doit = inlineLeafNoLoop size}
- val s = String.dropPrefix (s, String.size "inlineLeafNoLoop")
+ doit = (fn p =>
+ Inline.inlineLeafRepeat
+ (p, {size = size}))}
+ val s = String.dropPrefix (s, String.size "inlineLeafRepeat")
in
case nums s of
- SOME [] => mk 20
+ SOME [] => mk (SOME 20)
| SOME [size] => mk size
| _ => NONE
end
- else if String.hasPrefix (s, {prefix = "inlineLeaf"})
+ else if String.hasPrefix (s, {prefix = "inlineLeafRepeatNoLoop"})
then let
fun mk size =
- SOME {name = concat ["inlineLeaf(",
- Int.toString size, ")#",
+ SOME {name = concat ["inlineLeafRepeatNoLoop(",
+ Option.toString Int.toString size, ")#",
Int.toString (Counter.next count)],
- doit = inlineLeaf size}
- val s = String.dropPrefix (s, String.size "inlineLeaf")
+ doit = (fn p =>
+ Inline.inlineLeafRepeatNoLoop
+ (p, {size = size}))}
+ val s = String.dropPrefix (s, String.size "inlineLeafRepeatNoLoop")
in
case nums s of
- SOME [] => mk 20
+ SOME [] => mk (SOME 20)
| SOME [size] => mk size
| _ => NONE
end
+ else if String.hasPrefix (s, {prefix = "inlineLeafOnceNoLoop"})
+ then let
+ fun mk size =
+ SOME {name = concat ["inlineLeafOnceNoLoop(",
+ Option.toString Int.toString size, ")#",
+ Int.toString (Counter.next count)],
+ doit = (fn p =>
+ Inline.inlineLeafOnceNoLoop
+ (p, {size = size}))}
+ val s = String.dropPrefix (s, String.size "inlineLeafOnceNoLoop")
+ in
+ case nums s of
+ SOME [] => mk (SOME 20)
+ | SOME [size] => mk size
+ | _ => NONE
+ end
+ else if String.hasPrefix (s, {prefix = "inlineLeafOnce"})
+ then let
+ fun mk size =
+ SOME {name = concat ["inlineLeafOnce(",
+ Option.toString Int.toString size, ")#",
+ Int.toString (Counter.next count)],
+ doit = (fn p =>
+ Inline.inlineLeafOnce
+ (p, {size = size}))}
+ val s = String.dropPrefix (s, String.size "inlineLeafOnce")
+ in
+ case nums s of
+ SOME [] => mk (SOME 20)
+ | SOME [size] => mk size
+ | _ => NONE
+ end
else NONE
end
More information about the MLton-commit
mailing list