HCoop / hcoop / debian / mlton.git / blame
| Commit | Line | Data |
|---|---|---|
| 7f918cf1 CE |
1 | (* Copyright (C) 2009 Matthew Fluet. |
| 2 | * Copyright (C) 2004-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh | |
| 3 | * Jagannathan, and Stephen Weeks. | |
| 4 | * | |
| 5 | * MLton is released under a BSD-style license. | |
| 6 | * See the file MLton-LICENSE for details. | |
| 7 | *) | |
| 8 | ||
| 9 | functor Zone (S: SSA2_TRANSFORM_STRUCTS): SSA2_TRANSFORM = | |
| 10 | struct | |
| 11 | ||
| 12 | open S | |
| 13 | ||
| 14 | structure Graph = DirectedGraph | |
| 15 | local | |
| 16 | open Graph | |
| 17 | in | |
| 18 | structure Node = Node | |
| 19 | end | |
| 20 | ||
| 21 | structure Scope = UniqueId () | |
| 22 | ||
| 23 | fun zoneFunction f = | |
| 24 | let | |
| 25 | val {args, mayInline, name, raises, returns, start, ...} = Function.dest f | |
| 26 | datatype z = datatype Exp.t | |
| 27 | datatype z = datatype Statement.t | |
| 28 | val {get = labelInfo: Label.t -> {isInLoop: bool ref, | |
| 29 | isCut: bool ref}, ...} = | |
| 30 | Property.get (Label.plist, | |
| 31 | Property.initFun (fn _ => {isCut = ref false, | |
| 32 | isInLoop = ref false})) | |
| 33 | (* Mark nodes that are in loops so that we can avoid inserting tuple | |
| 34 | * constructions there. | |
| 35 | *) | |
| 36 | val {graph, nodeBlock, ...} = Function.controlFlow f | |
| 37 | val () = | |
| 38 | List.foreach | |
| 39 | (Graph.stronglyConnectedComponents graph, fn ns => | |
| 40 | let | |
| 41 | fun doit () = | |
| 42 | List.foreach | |
| 43 | (ns, fn n => | |
| 44 | #isInLoop (labelInfo (Block.label (nodeBlock n))) := true) | |
| 45 | in | |
| 46 | case ns of | |
| 47 | [n] => if Node.hasEdge {from = n, to = n} | |
| 48 | then doit () | |
| 49 | else () | |
| 50 | | _ => doit () | |
| 51 | end) | |
| 52 | val dominatorTree = Function.dominatorTree f | |
| 53 | (* Decide which labels to cut at. *) | |
| 54 | val cutDepth = !Control.zoneCutDepth | |
| 55 | fun addCuts (Tree.T (b, ts), depth: int) = | |
| 56 | let | |
| 57 | val depth = | |
| 58 | if depth = 0 | |
| 59 | then | |
| 60 | let | |
| 61 | val Block.T {label, ...} = b | |
| 62 | val {isCut, isInLoop, ...} = labelInfo label | |
| 63 | val () = | |
| 64 | if !isInLoop | |
| 65 | then | |
| 66 | Control.diagnostic | |
| 67 | (fn () => | |
| 68 | let | |
| 69 | open Layout | |
| 70 | in | |
| 71 | seq [str "skipping cut at ", | |
| 72 | Label.layout label] | |
| 73 | end) | |
| 74 | else isCut := true | |
| 75 | in | |
| 76 | cutDepth | |
| 77 | end | |
| 78 | else depth - 1 | |
| 79 | in | |
| 80 | Vector.foreach (ts, fn t => addCuts (t, depth)) | |
| 81 | end | |
| 82 | val () = addCuts (dominatorTree, cutDepth) | |
| 83 | (* Build a tuple of lives at each cut node. *) | |
| 84 | type info = {componentsRev: Var.t list ref, | |
| 85 | numComponents: int ref, | |
| 86 | scope: Scope.t, | |
| 87 | tuple: Var.t} | |
| 88 | fun newInfo () = | |
| 89 | {componentsRev = ref [], | |
| 90 | numComponents = ref 0, | |
| 91 | scope = Scope.new (), | |
| 92 | tuple = Var.newNoname ()} | |
| 93 | datatype varInfo = | |
| 94 | Global | |
| 95 | | Local of {blockCache: Var.t option ref, | |
| 96 | defScope: Scope.t, | |
| 97 | ty: Type.t, | |
| 98 | uses: {exp: Exp.t, | |
| 99 | scope: Scope.t} list ref} | |
| 100 | val {get = varInfo: Var.t -> varInfo, | |
| 101 | set = setVarInfo, ...} = | |
| 102 | Property.getSetOnce (Var.plist, | |
| 103 | Property.initFun (fn _ => Global)) | |
| 104 | val blockSelects: {blockCache: Var.t option ref, | |
| 105 | statement: Statement.t} list ref = ref [] | |
| 106 | fun addBlockSelects (ss: Statement.t vector): Statement.t vector = | |
| 107 | let | |
| 108 | val blockSelectsV = Vector.fromList (!blockSelects) | |
| 109 | val () = Vector.foreach (blockSelectsV, fn {blockCache, ...} => | |
| 110 | blockCache := NONE) | |
| 111 | val () = blockSelects := [] | |
| 112 | in | |
| 113 | Vector.concat [Vector.map (blockSelectsV, #statement), ss] | |
| 114 | end | |
| 115 | fun define (x: Var.t, ty: Type.t, info: info): unit = | |
| 116 | setVarInfo (x, Local {blockCache = ref NONE, | |
| 117 | defScope = #scope info, | |
| 118 | ty = ty, | |
| 119 | uses = ref []}) | |
| 120 | fun replaceVar (x: Var.t, | |
| 121 | {componentsRev, numComponents, scope, tuple}: info) | |
| 122 | : Var.t = | |
| 123 | case varInfo x of | |
| 124 | Global => x | |
| 125 | | Local {blockCache, defScope, ty, uses, ...} => | |
| 126 | case !blockCache of | |
| 127 | SOME y => y | |
| 128 | | _ => | |
| 129 | if Scope.equals (defScope, scope) | |
| 130 | then x | |
| 131 | else | |
| 132 | let | |
| 133 | fun new () = | |
| 134 | let | |
| 135 | val offset = !numComponents | |
| 136 | val () = List.push (componentsRev, x) | |
| 137 | val () = numComponents := 1 + offset | |
| 138 | val exp = Select {base = Base.Object tuple, | |
| 139 | offset = offset} | |
| 140 | val () = List.push (uses, {exp = exp, | |
| 141 | scope = scope}) | |
| 142 | in | |
| 143 | exp | |
| 144 | end | |
| 145 | val exp = | |
| 146 | case !uses of | |
| 147 | [] => new () | |
| 148 | | {exp, scope = scope'} :: _ => | |
| 149 | if Scope.equals (scope, scope') | |
| 150 | then exp | |
| 151 | else new () | |
| 152 | val y = Var.new x | |
| 153 | val () = blockCache := SOME y | |
| 154 | val () = | |
| 155 | List.push | |
| 156 | (blockSelects, | |
| 157 | {blockCache = blockCache, | |
| 158 | statement = Bind {exp = exp, | |
| 159 | ty = ty, | |
| 160 | var = SOME y}}) | |
| 161 | in | |
| 162 | y | |
| 163 | end | |
| 164 | val blocks = ref [] | |
| 165 | fun loop (Tree.T (b, ts), info: info) = | |
| 166 | let | |
| 167 | val Block.T {args, label, statements, transfer} = b | |
| 168 | val {isCut = ref isCut, ...} = labelInfo label | |
| 169 | val info' = | |
| 170 | if isCut | |
| 171 | then newInfo () | |
| 172 | else info | |
| 173 | val define = fn (x, t) => define (x, t, info') | |
| 174 | val () = Vector.foreach (args, define) | |
| 175 | val statements = | |
| 176 | Vector.map | |
| 177 | (statements, fn s => | |
| 178 | let | |
| 179 | val s = Statement.replaceUses (s, fn x => | |
| 180 | replaceVar (x, info')) | |
| 181 | val () = Statement.foreachDef (s, define) | |
| 182 | in | |
| 183 | s | |
| 184 | end) | |
| 185 | val transfer = | |
| 186 | Transfer.replaceVar (transfer, fn x => replaceVar (x, info')) | |
| 187 | val statements = addBlockSelects statements | |
| 188 | val () = Vector.foreach (ts, fn t => loop (t, info')) | |
| 189 | val statements = | |
| 190 | if not isCut | |
| 191 | then statements | |
| 192 | else | |
| 193 | let | |
| 194 | val {componentsRev, tuple, ...} = info' | |
| 195 | val components = Vector.fromListRev (!componentsRev) | |
| 196 | in | |
| 197 | if Vector.isEmpty components | |
| 198 | then statements | |
| 199 | else | |
| 200 | let | |
| 201 | val componentTys = | |
| 202 | Vector.map | |
| 203 | (components, fn x => | |
| 204 | case varInfo x of | |
| 205 | Global => Error.bug "Zone.zoneFunction: global component" | |
| 206 | | Local {ty, uses, ...} => | |
| 207 | (ignore (List.pop uses) | |
| 208 | ; {elt = ty, | |
| 209 | isMutable = false})) | |
| 210 | val components = | |
| 211 | Vector.map (components, fn x => | |
| 212 | replaceVar (x, info)) | |
| 213 | val s = | |
| 214 | Bind | |
| 215 | {exp = Object {args = components, con = NONE}, | |
| 216 | ty = Type.tuple (Prod.make componentTys), | |
| 217 | var = SOME tuple} | |
| 218 | in | |
| 219 | addBlockSelects (Vector.concat [Vector.new1 s, | |
| 220 | statements]) | |
| 221 | end | |
| 222 | end | |
| 223 | val () = List.push (blocks, | |
| 224 | Block.T {args = args, | |
| 225 | label = label, | |
| 226 | statements = statements, | |
| 227 | transfer = transfer}) | |
| 228 | in | |
| 229 | () | |
| 230 | end | |
| 231 | val () = loop (dominatorTree, newInfo ()) | |
| 232 | val blocks = Vector.fromList (!blocks) | |
| 233 | in | |
| 234 | Function.new {args = args, | |
| 235 | blocks = blocks, | |
| 236 | mayInline = mayInline, | |
| 237 | name = name, | |
| 238 | raises = raises, | |
| 239 | returns = returns, | |
| 240 | start = start} | |
| 241 | end | |
| 242 | ||
| 243 | fun maybeZoneFunction (f, ac) = | |
| 244 | let | |
| 245 | val {blocks, name, ...} = Function.dest f | |
| 246 | val () = | |
| 247 | Control.diagnostic | |
| 248 | (fn () => | |
| 249 | let | |
| 250 | open Layout | |
| 251 | in | |
| 252 | seq [Func.layout name, str " has ", str " blocks."] | |
| 253 | end) | |
| 254 | in | |
| 255 | if Vector.length blocks <= !Control.maxFunctionSize | |
| 256 | then f :: ac | |
| 257 | else zoneFunction f :: ac | |
| 258 | end | |
| 259 | ||
| 260 | fun transform2 (Program.T {datatypes, globals, functions, main}) = | |
| 261 | Program.T {datatypes = datatypes, | |
| 262 | globals = globals, | |
| 263 | functions = List.fold (functions, [], maybeZoneFunction), | |
| 264 | main = main} | |
| 265 | ||
| 266 | end |