Better profiling of SSA and SSA2 ILs
----------------------------------------------------------------------
U mlton/trunk/mlton/ssa/ssa-tree.fun
U mlton/trunk/mlton/ssa/ssa-tree2.fun
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/ssa/ssa-tree.fun
===================================================================
--- mlton/trunk/mlton/ssa/ssa-tree.fun 2007-06-21 17:52:40 UTC (rev 5664)
+++ mlton/trunk/mlton/ssa/ssa-tree.fun 2007-06-21 20:12:36 UTC (rev 5665)
@@ -1700,26 +1700,100 @@
let
val {args, blocks, mayInline, name, raises, returns, start} =
Function.dest f
+ val extraBlocks = ref []
+ val siF =
+ SourceInfo.function
+ {name = [Func.toString name],
+ region = Region.bogus}
+ val enterF = ProfileExp.Enter siF
+ val enterF = fn () => Statement.profile enterF
+ val leaveF = ProfileExp.Leave siF
+ val leaveF = fn () => Statement.profile leaveF
val blocks =
Vector.map
(blocks, fn Block.T {args, label, statements, transfer} =>
let
- val si =
- SourceInfo.function
- {name = [Label.toString label],
- region = Region.bogus}
- fun prof f = Vector.new1 (Statement.profile (f si))
+ val (enterFL, enterL, leaveL, leaveLF) =
+ if Vector.length statements = 0
+ then (fn () => Vector.new1 (enterF ()),
+ fn () => Vector.new0 (),
+ fn () => Vector.new0 (),
+ fn () => Vector.new1 (leaveF ()))
+ else let
+ val siL =
+ SourceInfo.function
+ {name = [Label.toString label],
+ region = Region.bogus}
+ val enterL = ProfileExp.Enter siL
+ val enterL = fn () => Statement.profile enterL
+ val leaveL = ProfileExp.Leave siL
+ val leaveL = fn () => Statement.profile leaveL
+ in
+ (fn () => Vector.new2 (enterF (), enterL ()),
+ fn () => Vector.new1 (enterL ()),
+ fn () => Vector.new1 (leaveL ()),
+ fn () => Vector.new2 (leaveL (), leaveF ()))
+ end
+ val enterStmts =
+ if Label.equals (label, start)
+ then enterFL ()
+ else enterL ()
+ fun doitLF () = (leaveLF (), transfer)
+ fun doitL () = (leaveL (), transfer)
+ fun doit () = (Vector.new0 (), transfer)
+ fun genHandler () =
+ case raises of
+ NONE => Handler.Caller
+ | SOME ts =>
+ let
+ val xs = Vector.map (ts, fn _ => Var.newNoname ())
+ val l = Label.newNoname ()
+ val _ =
+ List.push
+ (extraBlocks,
+ Block.T
+ {args = Vector.zip (xs, ts),
+ label = l,
+ statements = Vector.new1 (leaveF ()),
+ transfer = Transfer.Raise xs})
+ in
+ Handler.Handle l
+ end
+ val (leaveStmts, transfer) =
+ case transfer of
+ Transfer.Call {args, func, return} =>
+ (case return of
+ Return.Dead => doit ()
+ | Return.NonTail {cont, handler} =>
+ (case handler of
+ Handler.Dead => doitL ()
+ | Handler.Caller =>
+ let
+ val handler = genHandler ()
+ val return =
+ Return.NonTail {cont = cont,
+ handler = handler}
+ in
+ (leaveL (),
+ Transfer.Call {args = args,
+ func = func,
+ return = return})
+ end
+ | Handler.Handle _ => doitL ())
+ | Return.Tail => doitLF ())
+ | Transfer.Raise _ => doitLF ()
+ | Transfer.Return _ => doitLF ()
+ | _ => doitL ()
val statements =
Vector.concat
- [prof ProfileExp.Enter,
- statements,
- prof ProfileExp.Leave]
+ [enterStmts, statements, leaveStmts]
in
Block.T {args = args,
label = label,
statements = statements,
transfer = transfer}
end)
+ val blocks = Vector.concat [Vector.fromList (!extraBlocks), blocks]
in
Function.new {args = args,
blocks = blocks,
Modified: mlton/trunk/mlton/ssa/ssa-tree2.fun
===================================================================
--- mlton/trunk/mlton/ssa/ssa-tree2.fun 2007-06-21 17:52:40 UTC (rev 5664)
+++ mlton/trunk/mlton/ssa/ssa-tree2.fun 2007-06-21 20:12:36 UTC (rev 5665)
@@ -2146,26 +2146,100 @@
let
val {args, blocks, mayInline, name, raises, returns, start} =
Function.dest f
+ val extraBlocks = ref []
+ val siF =
+ SourceInfo.function
+ {name = [Func.toString name],
+ region = Region.bogus}
+ val enterF = ProfileExp.Enter siF
+ val enterF = fn () => Statement.profile enterF
+ val leaveF = ProfileExp.Leave siF
+ val leaveF = fn () => Statement.profile leaveF
val blocks =
Vector.map
(blocks, fn Block.T {args, label, statements, transfer} =>
let
- val si =
- SourceInfo.function
- {name = [Label.toString label],
- region = Region.bogus}
- fun prof f = Vector.new1 (Statement.profile (f si))
+ val (enterFL, enterL, leaveL, leaveLF) =
+ if Vector.length statements = 0
+ then (fn () => Vector.new1 (enterF ()),
+ fn () => Vector.new0 (),
+ fn () => Vector.new0 (),
+ fn () => Vector.new1 (leaveF ()))
+ else let
+ val siL =
+ SourceInfo.function
+ {name = [Label.toString label],
+ region = Region.bogus}
+ val enterL = ProfileExp.Enter siL
+ val enterL = fn () => Statement.profile enterL
+ val leaveL = ProfileExp.Leave siL
+ val leaveL = fn () => Statement.profile leaveL
+ in
+ (fn () => Vector.new2 (enterF (), enterL ()),
+ fn () => Vector.new1 (enterL ()),
+ fn () => Vector.new1 (leaveL ()),
+ fn () => Vector.new2 (leaveL (), leaveF ()))
+ end
+ val enterStmts =
+ if Label.equals (label, start)
+ then enterFL ()
+ else enterL ()
+ fun doitLF () = (leaveLF (), transfer)
+ fun doitL () = (leaveL (), transfer)
+ fun doit () = (Vector.new0 (), transfer)
+ fun genHandler () =
+ case raises of
+ NONE => Handler.Caller
+ | SOME ts =>
+ let
+ val xs = Vector.map (ts, fn _ => Var.newNoname ())
+ val l = Label.newNoname ()
+ val _ =
+ List.push
+ (extraBlocks,
+ Block.T
+ {args = Vector.zip (xs, ts),
+ label = l,
+ statements = Vector.new1 (leaveF ()),
+ transfer = Transfer.Raise xs})
+ in
+ Handler.Handle l
+ end
+ val (leaveStmts, transfer) =
+ case transfer of
+ Transfer.Call {args, func, return} =>
+ (case return of
+ Return.Dead => doit ()
+ | Return.NonTail {cont, handler} =>
+ (case handler of
+ Handler.Dead => doitL ()
+ | Handler.Caller =>
+ let
+ val handler = genHandler ()
+ val return =
+ Return.NonTail {cont = cont,
+ handler = handler}
+ in
+ (leaveL (),
+ Transfer.Call {args = args,
+ func = func,
+ return = return})
+ end
+ | Handler.Handle _ => doitL ())
+ | Return.Tail => doitLF ())
+ | Transfer.Raise _ => doitLF ()
+ | Transfer.Return _ => doitLF ()
+ | _ => doitL ()
val statements =
Vector.concat
- [prof ProfileExp.Enter,
- statements,
- prof ProfileExp.Leave]
+ [enterStmts, statements, leaveStmts]
in
Block.T {args = args,
label = label,
statements = statements,
transfer = transfer}
end)
+ val blocks = Vector.concat [Vector.fromList (!extraBlocks), blocks]
in
Function.new {args = args,
blocks = blocks,