HCoop / hcoop / debian / mlton.git / blame
| 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 Profile (S: PROFILE_STRUCTS): PROFILE = | |
| 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.T {exp = Exp.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 |