1 (* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
2 * Jagannathan, and Stephen Weeks.
4 * MLton is released under a BSD-style license.
5 * See the file MLton-LICENSE for details.
8 functor Profile2 (S: PROFILE2_STRUCTS): PROFILE2 =
13 fun addProfileFunction (f: Function.t) =
15 val {args, blocks, mayInline, name, raises, returns, start} =
17 val extraBlocks = ref []
20 {name = [Func.toString name],
21 region = Region.bogus}
22 val enterF = ProfileExp.Enter siF
23 val enterF = fn () => Statement.profile enterF
24 val leaveF = ProfileExp.Leave siF
25 val leaveF = fn () => Statement.profile leaveF
28 (blocks, fn Block.T {args, label, statements, transfer} =>
30 val (enterFL, enterL, leaveL, leaveLF) =
31 if Vector.isEmpty statements
32 then (fn () => Vector.new1 (enterF ()),
33 fn () => Vector.new0 (),
34 fn () => Vector.new0 (),
35 fn () => Vector.new1 (leaveF ()))
39 {name = [Label.toString label],
40 region = Region.bogus}
41 val enterL = ProfileExp.Enter siL
42 val enterL = fn () => Statement.profile enterL
43 val leaveL = ProfileExp.Leave siL
44 val leaveL = fn () => Statement.profile leaveL
46 (fn () => Vector.new2 (enterF (), enterL ()),
47 fn () => Vector.new1 (enterL ()),
48 fn () => Vector.new1 (leaveL ()),
49 fn () => Vector.new2 (leaveL (), leaveF ()))
52 if Label.equals (label, start)
55 fun doitLF () = (leaveLF (), transfer)
56 fun doitL () = (leaveL (), transfer)
57 fun doit () = (Vector.new0 (), transfer)
60 NONE => Handler.Caller
63 val xs = Vector.map (ts, fn _ => Var.newNoname ())
64 val l = Label.newNoname ()
69 {args = Vector.zip (xs, ts),
71 statements = Vector.new1 (leaveF ()),
72 transfer = Transfer.Raise xs})
76 val (leaveStmts, transfer) =
78 Transfer.Call {args, func, return} =>
80 Return.Dead => doit ()
81 | Return.NonTail {cont, handler} =>
83 Handler.Dead => doitL ()
86 val handler = genHandler ()
88 Return.NonTail {cont = cont,
92 Transfer.Call {args = args,
96 | Handler.Handle _ => doitL ())
97 | Return.Tail => doitLF ())
98 | Transfer.Raise _ => doitLF ()
99 | Transfer.Return _ => doitLF ()
103 [enterStmts, statements, leaveStmts]
105 Block.T {args = args,
107 statements = statements,
110 val blocks = Vector.concat [Vector.fromList (!extraBlocks), blocks]
112 Function.new {args = args,
114 mayInline = mayInline,
121 fun addProfile (Program.T {datatypes, functions, globals, main}) =
122 Program.T {datatypes = datatypes,
123 functions = List.revMap (functions, addProfileFunction),
127 fun dropProfileFunction f =
129 val {args, blocks, mayInline, name, raises, returns, start} =
133 (blocks, fn Block.T {args, label, statements, transfer} =>
134 Block.T {args = args,
136 statements = Vector.keepAll
138 fn Statement.Profile _ => false
140 transfer = transfer})
142 Function.new {args = args,
144 mayInline = mayInline,
151 fun dropProfile (Program.T {datatypes, globals, functions, main}) =
152 (Control.profile := Control.ProfileNone
153 ; Program.T {datatypes = datatypes,
155 functions = List.revMap (functions, dropProfileFunction),