Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh |
2 | * Jagannathan, and Stephen Weeks. | |
3 | * | |
4 | * MLton is released under a BSD-style license. | |
5 | * See the file MLton-LICENSE for details. | |
6 | *) | |
7 | ||
8 | functor Profile2 (S: PROFILE2_STRUCTS): PROFILE2 = | |
9 | struct | |
10 | ||
11 | open S | |
12 | ||
13 | fun addProfileFunction (f: Function.t) = | |
14 | let | |
15 | val {args, blocks, mayInline, name, raises, returns, start} = | |
16 | Function.dest f | |
17 | val extraBlocks = ref [] | |
18 | val siF = | |
19 | SourceInfo.function | |
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 | |
26 | val blocks = | |
27 | Vector.map | |
28 | (blocks, fn Block.T {args, label, statements, transfer} => | |
29 | let | |
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 ())) | |
36 | else let | |
37 | val siL = | |
38 | SourceInfo.function | |
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 | |
45 | in | |
46 | (fn () => Vector.new2 (enterF (), enterL ()), | |
47 | fn () => Vector.new1 (enterL ()), | |
48 | fn () => Vector.new1 (leaveL ()), | |
49 | fn () => Vector.new2 (leaveL (), leaveF ())) | |
50 | end | |
51 | val enterStmts = | |
52 | if Label.equals (label, start) | |
53 | then enterFL () | |
54 | else enterL () | |
55 | fun doitLF () = (leaveLF (), transfer) | |
56 | fun doitL () = (leaveL (), transfer) | |
57 | fun doit () = (Vector.new0 (), transfer) | |
58 | fun genHandler () = | |
59 | case raises of | |
60 | NONE => Handler.Caller | |
61 | | SOME ts => | |
62 | let | |
63 | val xs = Vector.map (ts, fn _ => Var.newNoname ()) | |
64 | val l = Label.newNoname () | |
65 | val _ = | |
66 | List.push | |
67 | (extraBlocks, | |
68 | Block.T | |
69 | {args = Vector.zip (xs, ts), | |
70 | label = l, | |
71 | statements = Vector.new1 (leaveF ()), | |
72 | transfer = Transfer.Raise xs}) | |
73 | in | |
74 | Handler.Handle l | |
75 | end | |
76 | val (leaveStmts, transfer) = | |
77 | case transfer of | |
78 | Transfer.Call {args, func, return} => | |
79 | (case return of | |
80 | Return.Dead => doit () | |
81 | | Return.NonTail {cont, handler} => | |
82 | (case handler of | |
83 | Handler.Dead => doitL () | |
84 | | Handler.Caller => | |
85 | let | |
86 | val handler = genHandler () | |
87 | val return = | |
88 | Return.NonTail {cont = cont, | |
89 | handler = handler} | |
90 | in | |
91 | (leaveL (), | |
92 | Transfer.Call {args = args, | |
93 | func = func, | |
94 | return = return}) | |
95 | end | |
96 | | Handler.Handle _ => doitL ()) | |
97 | | Return.Tail => doitLF ()) | |
98 | | Transfer.Raise _ => doitLF () | |
99 | | Transfer.Return _ => doitLF () | |
100 | | _ => doitL () | |
101 | val statements = | |
102 | Vector.concat | |
103 | [enterStmts, statements, leaveStmts] | |
104 | in | |
105 | Block.T {args = args, | |
106 | label = label, | |
107 | statements = statements, | |
108 | transfer = transfer} | |
109 | end) | |
110 | val blocks = Vector.concat [Vector.fromList (!extraBlocks), blocks] | |
111 | in | |
112 | Function.new {args = args, | |
113 | blocks = blocks, | |
114 | mayInline = mayInline, | |
115 | name = name, | |
116 | raises = raises, | |
117 | returns = returns, | |
118 | start = start} | |
119 | end | |
120 | ||
121 | fun addProfile (Program.T {datatypes, functions, globals, main}) = | |
122 | Program.T {datatypes = datatypes, | |
123 | functions = List.revMap (functions, addProfileFunction), | |
124 | globals = globals, | |
125 | main = main} | |
126 | ||
127 | fun dropProfileFunction f = | |
128 | let | |
129 | val {args, blocks, mayInline, name, raises, returns, start} = | |
130 | Function.dest f | |
131 | val blocks = | |
132 | Vector.map | |
133 | (blocks, fn Block.T {args, label, statements, transfer} => | |
134 | Block.T {args = args, | |
135 | label = label, | |
136 | statements = Vector.keepAll | |
137 | (statements, | |
138 | fn Statement.Profile _ => false | |
139 | | _ => true), | |
140 | transfer = transfer}) | |
141 | in | |
142 | Function.new {args = args, | |
143 | blocks = blocks, | |
144 | mayInline = mayInline, | |
145 | name = name, | |
146 | raises = raises, | |
147 | returns = returns, | |
148 | start = start} | |
149 | end | |
150 | ||
151 | fun dropProfile (Program.T {datatypes, globals, functions, main}) = | |
152 | (Control.profile := Control.ProfileNone | |
153 | ; Program.T {datatypes = datatypes, | |
154 | globals = globals, | |
155 | functions = List.revMap (functions, dropProfileFunction), | |
156 | main = main}) | |
157 | ||
158 | end |