mlton/ssa/common-arg.fun

   1 (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  * Copyright (C) 1997-2000 NEC Research Institute.
   4  *
   5  * MLton is released under a BSD-style license.
   6  * See the file MLton-LICENSE for details.
   7  *)
   8
   9 functor CommonArg (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM =
  10 struct
  11
  12 open S
  13 open Exp Transfer
  14
  15 structure Graph = DirectedGraph
  16 structure Node = Graph.Node
  17
  18 structure VarInfo =
  19   struct
  20     datatype t = T of {node: unit DirectedGraph.Node.t}
  21
  22     fun layout lNode (T {node, ...}) =
  23       let open Layout
  24       in record [("node", lNode node)]
  25       end
  26
  27     local
  28       fun make f (T r) = f r
  29     in
  30       val node = make #node
  31     end
  32
  33     fun new node = T {node = node}
  34   end
  35
  36 structure NodeInfo =
  37   struct
  38     datatype t = T of {var: Var.t}
  39
  40     local
  41       fun make f (T r) = f r
  42     in
  43       val var = make #var
  44     end
  45
  46     fun new var = T {var = var}
  47   end
  48
  49 fun transform (Program.T {datatypes, globals, functions, main}) =
  50    let
  51       val {get = nodeInfo: unit Node.t -> NodeInfo.t,
  52            set = setNodeInfo, ...} =
  53          Property.getSetOnce
  54          (Node.plist,
  55           Property.initRaise ("CommonArg.nodeInfo", Node.layout))
  56       val nodeInfo =
  57          Trace.trace ("CommonArg.nodeInfo", Layout.ignore, Layout.ignore)
  58          nodeInfo
  59       val {get = labelArgs: Label.t -> (Var.t * Type.t) vector,
  60            set = setLabelArgs, ...} =
  61          Property.getSetOnce
  62          (Label.plist,
  63           Property.initRaise ("CommonArg.labelArgs", Label.layout))
  64       val labelArgs =
  65          Trace.trace ("CommonArg.labelArgs", Layout.ignore, Layout.ignore)
  66          labelArgs
  67       (* Argument flow graph. *)
  68       val G = Graph.new ()
  69       val root = Graph.newNode G
  70       fun newNode (v: Var.t): unit Node.t =
  71          let
  72             val node = Graph.newNode G
  73             val () = setNodeInfo (node, NodeInfo.new v)
  74          in
  75             node
  76          end
  77       fun newRootedNode v =
  78          let
  79             val node = newNode v
  80             val _ = Graph.addEdge (G, {from = root, to = node})
  81          in
  82             node
  83          end
  84       val {get = varInfo: Var.t -> VarInfo.t,
  85            set = setVarInfo, ...} =
  86          Property.getSetOnce (Var.plist,
  87                               Property.initFun (VarInfo.new o newRootedNode))
  88       val varInfo =
  89          Trace.trace ("CommonArg.varInfo", Layout.ignore, Layout.ignore)
  90          varInfo
  91       val varNode = VarInfo.node o varInfo
  92       (* Analyze *)
  93       val () =
  94          List.foreach
  95          (functions, fn f =>
  96           let
  97              val {blocks, ...} = Function.dest f
  98              val () =
  99                 Vector.foreach
 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. *)
 112             fun visitVar v =
 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)
 117           in
 118              Vector.foreach
 119              (blocks, fn Block.T {transfer, ...} =>
 120               case transfer of
 121                  Arith {overflow, success, ...} =>
 122                     (visitLabelArgs overflow; visitLabelArgs success)
 123                | Bug => ()
 124                | Call {return, ...} =>
 125                     (case return of
 126                         Return.NonTail {cont, handler} =>
 127                            (visitLabelArgs cont
 128                             ; (case handler of
 129                                   Handler.Handle hand => visitLabelArgs hand
 130                                 | _ => ()))
 131                       | _ => ())
 132                | Case {cases, default, ...} =>
 133                     (Cases.foreach (cases, visitLabelArgs)
 134                      ; Option.app (default, visitLabelArgs))
 135                | Goto {dst, args} => flowVarsLabelArgs (args, dst)
 136                | Raise _ => ()
 137                | Return _ => ()
 138                | Runtime {return, ...} => visitLabelArgs return)
 139           end)
 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)
 145                                     then v
 146                                  else NodeInfo.var (nodeInfo parent)
 147           | Graph.Unreachable => v
 148           | Graph.Root => v
 149       fun keepVar v = Var.equals (v, getVar v)
 150       (* Diagnostics *)
 151       val () =
 152          Control.diagnostics
 153          (fn display =>
 154           List.foreach
 155           (functions, fn f =>
 156            let
 157               val {blocks, name, ...} = Function.dest f
 158               open Layout
 159               fun lNode n =
 160                  record [("idom", case idom n of
 161                           Graph.Idom parent =>
 162                              if Node.equals (parent, root)
 163                                 then str "root"
 164                              else Var.layout (NodeInfo.var (nodeInfo parent))
 165                         | _ => str "???")]
 166            in
 167               display (seq [str "\n", Func.layout name])
 168               ; (Vector.foreach
 169                  (blocks, fn Block.T {args, label, ...} =>
 170                   if Vector.exists (args, not o keepVar o #1)
 171                      then
 172                         display
 173                         (seq [Label.layout label,
 174                               str " ",
 175                               Vector.layout
 176                               (fn (v, _) =>
 177                                seq [Var.layout v,
 178                                     str ": ",
 179                                     VarInfo.layout lNode (varInfo v)])
 180                               args])
 181                   else ()))
 182            end))
 183       (* Transform *)
 184       val shrink = shrinkFunction {globals = globals}
 185       val functions =
 186          List.revMap
 187          (functions, fn f =>
 188           let
 189              val {args, blocks, mayInline, name, start, raises, returns} =
 190                 Function.dest f
 191              val blocks =
 192                 Vector.map
 193                 (blocks, fn Block.T {args, label, statements, transfer} =>
 194                  let
 195                     val {yes = args, no = rems} =
 196                        Vector.partition (args, keepVar o #1)
 197                     val statements =
 198                        if Vector.isEmpty rems
 199                           then statements
 200                        else Vector.concat [Vector.map
 201                                            (rems, fn (v, ty) =>
 202                                             Statement.T {var = SOME v,
 203                                                          ty = ty,
 204                                                          exp = Var (getVar v)}),
 205                                            statements]
 206                     val transfer =
 207                        case transfer of
 208                           Goto {args, dst} =>
 209                              let
 210                                 val args =
 211                                    Vector.keepAllMap2
 212                                    (args, labelArgs dst, fn (arg, (v, _)) =>
 213                                     if keepVar v
 214                                        then SOME arg
 215                                     else NONE)
 216                              in
 217                                 Goto {args = args, dst = dst}
 218                              end
 219                         | _ => transfer
 220                  in
 221                     Block.T {args = args,
 222                              label = label,
 223                              statements = statements,
 224                              transfer = transfer}
 225                  end)
 226           in
 227              shrink (Function.new {args = args,
 228                                    blocks = blocks,
 229                                    mayInline = mayInline,
 230                                    name = name,
 231                                    start = start,
 232                                    raises = raises,
 233                                    returns = returns})
 234           end)
 235       val program =
 236          Program.T {datatypes = datatypes,
 237                     globals = globals,
 238                     functions = functions,
 239                     main = main}
 240       val () = Program.clearTop program
 241    in
 242       program
 243    end
 244
 245 end