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 CommonArg (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM =
15 structure Graph = DirectedGraph
16 structure Node = Graph.Node
20 datatype t = T of {node: unit DirectedGraph.Node.t}
22 fun layout lNode (T {node, ...}) =
24 in record [("node", lNode node)]
28 fun make f (T r) = f r
33 fun new node = T {node = node}
38 datatype t = T of {var: Var.t}
41 fun make f (T r) = f r
46 fun new var = T {var = var}
49 fun transform (Program.T {datatypes, globals, functions, main}) =
51 val {get = nodeInfo: unit Node.t -> NodeInfo.t,
52 set = setNodeInfo, ...} =
55 Property.initRaise ("CommonArg.nodeInfo", Node.layout))
57 Trace.trace ("CommonArg.nodeInfo", Layout.ignore, Layout.ignore)
59 val {get = labelArgs: Label.t -> (Var.t * Type.t) vector,
60 set = setLabelArgs, ...} =
63 Property.initRaise ("CommonArg.labelArgs", Label.layout))
65 Trace.trace ("CommonArg.labelArgs", Layout.ignore, Layout.ignore)
67 (* Argument flow graph. *)
69 val root = Graph.newNode G
70 fun newNode (v: Var.t): unit Node.t =
72 val node = Graph.newNode G
73 val () = setNodeInfo (node, NodeInfo.new v)
80 val _ = Graph.addEdge (G, {from = root, to = node})
84 val {get = varInfo: Var.t -> VarInfo.t,
85 set = setVarInfo, ...} =
86 Property.getSetOnce (Var.plist,
87 Property.initFun (VarInfo.new o newRootedNode))
89 Trace.trace ("CommonArg.varInfo", Layout.ignore, Layout.ignore)
91 val varNode = VarInfo.node o varInfo
97 val {blocks, ...} = Function.dest f
100 (blocks, fn Block.T {label, args, ...} =>
101 (setLabelArgs (label, args)
102 ; Vector.foreach (args, fn (v, _) =>
103 setVarInfo (v, VarInfo.new (newNode v)))))
104 (* Flow Transfer.Goto arguments. *)
105 fun flowVarVar (v, v'): unit =
106 ignore (Graph.addEdge (G, {from = varNode v, to = varNode v'}))
107 fun flowVarVarTy (v, (v', _)) = flowVarVar (v, v')
108 fun flowVarsVarTys (vs, vts') =
109 Vector.foreach2 (vs, vts', flowVarVarTy)
110 fun flowVarsLabelArgs (vs, l) = flowVarsVarTys (vs, labelArgs l)
111 (* Visit in unknown contexts. *)
113 ignore (Graph.addEdge (G, {from = root, to = varNode v}))
114 fun visitVarTy (v, _) = visitVar v
115 fun visitArgs args = Vector.foreach (args, visitVarTy)
116 fun visitLabelArgs l = visitArgs (labelArgs l)
119 (blocks, fn Block.T {transfer, ...} =>
121 Arith {overflow, success, ...} =>
122 (visitLabelArgs overflow; visitLabelArgs success)
124 | Call {return, ...} =>
126 Return.NonTail {cont, handler} =>
129 Handler.Handle hand => visitLabelArgs hand
132 | Case {cases, default, ...} =>
133 (Cases.foreach (cases, visitLabelArgs)
134 ; Option.app (default, visitLabelArgs))
135 | Goto {dst, args} => flowVarsLabelArgs (args, dst)
138 | Runtime {return, ...} => visitLabelArgs return)
140 val () = Graph.removeDuplicateEdges G
141 val {idom} = Graph.dominators (G, {root = root})
142 fun getVar (v: Var.t): Var.t =
143 case idom (varNode v) of
144 Graph.Idom parent => if Node.equals (parent, root)
146 else NodeInfo.var (nodeInfo parent)
147 | Graph.Unreachable => v
149 fun keepVar v = Var.equals (v, getVar v)
157 val {blocks, name, ...} = Function.dest f
160 record [("idom", case idom n of
162 if Node.equals (parent, root)
164 else Var.layout (NodeInfo.var (nodeInfo parent))
167 display (seq [str "\n", Func.layout name])
169 (blocks, fn Block.T {args, label, ...} =>
170 if Vector.exists (args, not o keepVar o #1)
173 (seq [Label.layout label,
179 VarInfo.layout lNode (varInfo v)])
184 val shrink = shrinkFunction {globals = globals}
189 val {args, blocks, mayInline, name, start, raises, returns} =
193 (blocks, fn Block.T {args, label, statements, transfer} =>
195 val {yes = args, no = rems} =
196 Vector.partition (args, keepVar o #1)
198 if Vector.isEmpty rems
200 else Vector.concat [Vector.map
202 Statement.T {var = SOME v,
204 exp = Var (getVar v)}),
212 (args, labelArgs dst, fn (arg, (v, _)) =>
217 Goto {args = args, dst = dst}
221 Block.T {args = args,
223 statements = statements,
227 shrink (Function.new {args = args,
229 mayInline = mayInline,
236 Program.T {datatypes = datatypes,
238 functions = functions,
240 val () = Program.clearTop program