1 (* Copyright (C) 2009 Matthew Fluet.
2 * Copyright (C) 2004-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh
3 * Jagannathan, and Stephen Weeks.
5 * MLton is released under a BSD-style license.
6 * See the file MLton-LICENSE for details.
9 functor Zone (S: SSA2_TRANSFORM_STRUCTS): SSA2_TRANSFORM =
14 structure Graph = DirectedGraph
21 structure Scope = UniqueId ()
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.
36 val {graph, nodeBlock, ...} = Function.controlFlow f
39 (Graph.stronglyConnectedComponents graph, fn ns =>
44 #isInLoop (labelInfo (Block.label (nodeBlock n))) := true)
47 [n] => if Node.hasEdge {from = n, to = n}
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) =
61 val Block.T {label, ...} = b
62 val {isCut, isInLoop, ...} = labelInfo label
71 seq [str "skipping cut at ",
80 Vector.foreach (ts, fn t => addCuts (t, depth))
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,
89 {componentsRev = ref [],
90 numComponents = ref 0,
92 tuple = Var.newNoname ()}
95 | Local of {blockCache: Var.t option ref,
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 =
108 val blockSelectsV = Vector.fromList (!blockSelects)
109 val () = Vector.foreach (blockSelectsV, fn {blockCache, ...} =>
111 val () = blockSelects := []
113 Vector.concat [Vector.map (blockSelectsV, #statement), ss]
115 fun define (x: Var.t, ty: Type.t, info: info): unit =
116 setVarInfo (x, Local {blockCache = ref NONE,
117 defScope = #scope info,
120 fun replaceVar (x: Var.t,
121 {componentsRev, numComponents, scope, tuple}: info)
125 | Local {blockCache, defScope, ty, uses, ...} =>
129 if Scope.equals (defScope, scope)
135 val offset = !numComponents
136 val () = List.push (componentsRev, x)
137 val () = numComponents := 1 + offset
138 val exp = Select {base = Base.Object tuple,
140 val () = List.push (uses, {exp = exp,
148 | {exp, scope = scope'} :: _ =>
149 if Scope.equals (scope, scope')
153 val () = blockCache := SOME y
157 {blockCache = blockCache,
158 statement = Bind {exp = exp,
165 fun loop (Tree.T (b, ts), info: info) =
167 val Block.T {args, label, statements, transfer} = b
168 val {isCut = ref isCut, ...} = labelInfo label
173 val define = fn (x, t) => define (x, t, info')
174 val () = Vector.foreach (args, define)
179 val s = Statement.replaceUses (s, fn x =>
180 replaceVar (x, info'))
181 val () = Statement.foreachDef (s, define)
186 Transfer.replaceVar (transfer, fn x => replaceVar (x, info'))
187 val statements = addBlockSelects statements
188 val () = Vector.foreach (ts, fn t => loop (t, info'))
194 val {componentsRev, tuple, ...} = info'
195 val components = Vector.fromListRev (!componentsRev)
197 if Vector.isEmpty components
205 Global => Error.bug "Zone.zoneFunction: global component"
206 | Local {ty, uses, ...} =>
207 (ignore (List.pop uses)
211 Vector.map (components, fn x =>
212 replaceVar (x, info))
215 {exp = Object {args = components, con = NONE},
216 ty = Type.tuple (Prod.make componentTys),
219 addBlockSelects (Vector.concat [Vector.new1 s,
223 val () = List.push (blocks,
224 Block.T {args = args,
226 statements = statements,
227 transfer = transfer})
231 val () = loop (dominatorTree, newInfo ())
232 val blocks = Vector.fromList (!blocks)
234 Function.new {args = args,
236 mayInline = mayInline,
243 fun maybeZoneFunction (f, ac) =
245 val {blocks, name, ...} = Function.dest f
252 seq [Func.layout name, str " has ", str " blocks."]
255 if Vector.length blocks <= !Control.maxFunctionSize
257 else zoneFunction f :: ac
260 fun transform2 (Program.T {datatypes, globals, functions, main}) =
261 Program.T {datatypes = datatypes,
263 functions = List.fold (functions, [], maybeZoneFunction),