1 (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
2 * Jagannathan, and Stephen Weeks.
3 * Copyright (C) 1997-2000 NEC Research Institute.
5 * MLton is released under a BSD-style license.
6 * See the file MLton-LICENSE for details.
9 functor Chunkify (S: CHUNKIFY_STRUCTS): CHUNKIFY =
13 datatype z = datatype Transfer.t
15 (* A chunkifier that puts each function in its own chunk. *)
16 fun chunkPerFunc (Program.T {functions, main, ...}) =
18 (main :: functions, fn f =>
20 val {name, blocks, ...} = Function.dest f
22 {funcs = Vector.new1 name,
23 labels = Vector.map (blocks, Block.label)}
26 (* A simple chunkifier that puts all code in the same chunk.
28 fun oneChunk (Program.T {functions, main, ...}) =
30 val functions = main :: functions
33 {funcs = Vector.fromListMap (functions, Function.name),
34 labels = Vector.concatV (Vector.fromListMap
36 Vector.map (Function.blocks f, Block.label)))}
39 fun blockSize (Block.T {statements, transfer, ...}): int =
43 Switch (Switch.T {cases, ...}) => 1 + Vector.length cases
46 if !Control.profile = Control.ProfileNone
47 then Vector.length statements
48 else Vector.fold (statements, 0, fn (s, ac) =>
50 Statement.ProfileLabel _ => ac
53 statementsSize + transferSize
56 (* Compute the list of functions that each function returns to *)
57 fun returnsTo (Program.T {functions, main, ...}) =
59 val functions = main :: functions
60 val {get: Func.t -> {returnsTo: Label.t list ref,
61 tailCalls: Func.t list ref},
63 Property.get (Func.plist,
64 Property.initFun (fn _ =>
67 fun returnTo (f: Func.t, j: Label.t): unit =
69 val {returnsTo, tailCalls} = get f
71 if List.exists (!returnsTo, fn j' => Label.equals (j, j'))
73 else (List.push (returnsTo, j)
74 ; List.foreach (!tailCalls, fn f => returnTo (f, j)))
76 fun tailCall (from: Func.t, to: Func.t): unit =
78 val {returnsTo, tailCalls} = get from
80 if List.exists (!tailCalls, fn f => Func.equals (to, f))
82 else (List.push (tailCalls, to)
83 ; List.foreach (!returnsTo, fn j => returnTo (to, j)))
89 val {name, blocks, ...} = Function.dest f
92 (blocks, fn Block.T {transfer, ...} =>
94 Call {func, return, ...} => (case return of
95 Return.NonTail {cont, ...} =>
97 | _ => tailCall (name, func))
103 returnsTo = ! o #returnsTo o get}
106 structure Graph = EquivalenceGraph
107 structure Class = Graph.Class
108 fun coalesce (program as Program.T {functions, main, ...}, limit) =
110 val functions = main :: functions
111 val graph = Graph.new ()
112 val {get = funcClass: Func.t -> Class.t, set = setFuncClass,
113 rem = remFuncClass, ...} =
114 Property.getSetOnce (Func.plist,
115 Property.initRaise ("class", Func.layout))
116 val {get = labelClass: Label.t -> Class.t, set = setLabelClass,
117 rem = remLabelClass, ...} =
118 Property.getSetOnce (Label.plist,
119 Property.initRaise ("class", Label.layout))
120 (* Build the initial partition.
121 * Ensure that all Ssa labels that jump to one another are in the same
128 val {name, blocks, start, ...} = Function.dest f
131 (blocks, fn b as Block.T {label, ...} =>
132 setLabelClass (label,
133 Graph.newClass (graph, {size = blockSize b})))
134 val _ = setFuncClass (name, labelClass start)
137 (blocks, fn Block.T {label, transfer, ...} =>
139 val c = labelClass label
140 fun same (j: Label.t): unit =
141 Graph.== (graph, c, labelClass j)
144 Arith {overflow, success, ...} =>
145 (same overflow; same success)
146 | CCall {return, ...} => Option.app (return, same)
147 | Goto {dst, ...} => same dst
148 | Switch s => Switch.foreachLabel (s, same)
154 val {returnsTo, rem = remReturnsTo} = returnsTo program
155 (* Add edges, and then coalesce the graph. *)
160 val {name, blocks, ...} = Function.dest f
161 val returnsTo = List.revMap (returnsTo name, labelClass)
164 (blocks, fn Block.T {label, transfer, ...} =>
167 Graph.addEdge (graph, labelClass label,
171 val from = labelClass label
175 Graph.addEdge (graph, from, c))
184 else Graph.coarsen (graph, {maxClassSize = limit})
185 type chunk = {funcs: Func.t list ref,
186 labels: Label.t list ref}
187 val chunks: chunk list ref = ref []
188 val {get = classChunk: Class.t -> chunk, ...} =
191 Property.initFun (fn _ =>
193 val c = {funcs = ref [],
195 val _ = List.push (chunks, c)
203 sel: chunk -> 'a list ref): unit =
204 List.push (sel (classChunk (get l)), l)
209 val {name, blocks, ...} = Function.dest f
210 val _ = new (name, funcClass, #funcs)
213 (blocks, fn Block.T {label, ...} =>
214 new (label, labelClass, #labels))
223 val {blocks, name, ...} = Function.dest f
224 val _ = remFuncClass name
225 val _ = remReturnsTo name
226 val _ = Vector.foreach (blocks, remLabelClass o Block.label)
231 Vector.fromListMap (!chunks, fn {funcs, labels} =>
232 {funcs = Vector.fromList (!funcs),
233 labels = Vector.fromList (!labels)})
237 case !Control.chunk of
238 Control.ChunkPerFunc => chunkPerFunc p
239 | Control.OneChunk => oneChunk p
240 | Control.Coalesce {limit} => coalesce (p, limit)
245 val chunks = chunkify p
251 val _ = display (str "Chunkification:")
254 (chunks, fn {funcs, labels} =>
256 (record ([("funcs", Vector.layout Func.layout funcs),
257 ("jumps", Vector.layout Label.layout labels)])))