mlton/ssa/prepasses.fun

   1 (* Copyright (C) 2009,2017 Matthew Fluet.
   2  * Copyright (C) 2005-2007 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 PrePasses (S: PREPASSES_STRUCTS): PREPASSES =
  10 struct
  11
  12 open S
  13
  14 open Exp Transfer
  15
  16 (* A critical edge is one that connects a block with two or more
  17  * succesors to one with two or more predecessors.
  18  * This prepass breaks all critical edges by inserting an eta-block.
  19  * For some analyses and transformations, simply ensuring the unique
  20  * successor or predecessor property is sufficient.  (For example, see
  21  * the comments at the end of "Conditional Constant Propagation" in
  22  * Section 19.3 of Appel's "Modern Compiler Implementation in ML".)
  23  * However, passes that require critical edges to be broken in order
  24  * to accomodate code motion (for example, PRE), should also break an
  25  * edge that connects a block with non-goto transfer to one with two
  26  * or more predecessors.
  27  *)
  28 structure CriticalEdges =
  29 struct
  30
  31 structure LabelInfo =
  32    struct
  33       datatype t = T of {args: (Var.t * Type.t) vector,
  34                          inDeg: int ref,
  35                          mustBreak: bool,
  36                          outDeg: int ref}
  37
  38       local
  39          fun make f (T r) = f r
  40          fun make' f = (make f, ! o (make f))
  41       in
  42          val args = make #args
  43          val (inDeg', inDeg) = make' #inDeg
  44          val mustBreak = make #mustBreak
  45          val (outDeg', outDeg) = make' #outDeg
  46       end
  47
  48       fun new (args, mustBreak): t = T {args = args,
  49                                         inDeg = ref 0,
  50                                         mustBreak = mustBreak,
  51                                         outDeg = ref 0}
  52    end
  53
  54 fun breakFunction (f, {codeMotion: bool}) =
  55    let
  56       val {get = labelInfo: Label.t -> LabelInfo.t,
  57            set = setLabelInfo, ...} =
  58          Property.getSetOnce
  59          (Label.plist, Property.initRaise ("CriticalEdges.labelInfo", Label.layout))
  60       val argsLabel = LabelInfo.args o labelInfo
  61       val inDeg = LabelInfo.inDeg o labelInfo
  62       val inDeg' = LabelInfo.inDeg' o labelInfo
  63       val mustBreak = LabelInfo.mustBreak o labelInfo
  64       val outDeg = LabelInfo.outDeg o labelInfo
  65       val outDeg' = LabelInfo.outDeg' o labelInfo
  66
  67       val {args, blocks, mayInline,
  68            name, raises, returns, start} = Function.dest f
  69
  70       val _ =
  71          Vector.foreach
  72          (blocks, fn Block.T {args, label, transfer, ...} =>
  73           let
  74              val mustBreak =
  75                 case transfer of
  76                    Bug => false (* no successors *)
  77                  | Goto _ => false
  78                  | Raise _ => false (* no successors *)
  79                  | Return _ => false (* no successors *)
  80                  | _ => true
  81           in
  82              setLabelInfo (label, LabelInfo.new (args, mustBreak))
  83           end)
  84       val _ =
  85          Vector.foreach
  86          (blocks, fn Block.T {label, transfer, ...} =>
  87           let
  88              val outDeg' = outDeg' label
  89              fun doit l =
  90                 (Int.inc outDeg'
  91                  ; Int.inc (inDeg' l))
  92           in
  93              Transfer.foreachLabel
  94              (transfer, doit)
  95           end)
  96
  97       val newBlocks = ref []
  98       fun newBlock l =
  99          let
 100             val l' = Label.newString "L_crit"
 101             val args =
 102                Vector.map
 103                (argsLabel l, fn (x, ty) =>
 104                 (Var.new x, ty))
 105             val _ =
 106                List.push
 107                (newBlocks,
 108                 Block.T {args = args,
 109                          label = l',
 110                          statements = Vector.new0 (),
 111                          transfer = Goto {dst = l,
 112                                           args = Vector.map(args, #1)}})
 113          in
 114             l'
 115          end
 116       val blocks =
 117          Vector.map
 118          (blocks, fn b as Block.T {args, label, statements, transfer} =>
 119           if (codeMotion andalso mustBreak label)
 120              orelse outDeg label >= 2
 121              then let
 122                      fun doit t =
 123                         Transfer.replaceLabel
 124                         (t, fn l =>
 125                          if inDeg l > 1
 126                             then newBlock l
 127                             else l)
 128                   in
 129                      Block.T {args = args,
 130                               label = label,
 131                               statements = statements,
 132                               transfer = doit transfer}
 133                   end
 134              else b)
 135    in
 136       Function.new {args = args,
 137                     blocks = Vector.concat [blocks, Vector.fromList (!newBlocks)],
 138                     mayInline = mayInline,
 139                     name = name,
 140                     raises = raises,
 141                     returns = returns,
 142                     start = start}
 143    end
 144
 145 fun break (Program.T {datatypes, globals, functions, main}, codeMotion) =
 146    let
 147       val functions =
 148          List.revMap (functions, fn f =>
 149                       breakFunction (f, codeMotion))
 150    in
 151       Program.T {datatypes = datatypes,
 152                  globals = globals,
 153                  functions = functions,
 154                  main = main}
 155    end
 156 end
 157
 158 val breakCriticalEdgesFunction = CriticalEdges.breakFunction
 159 (* quell unused warning *)
 160 val _ = breakCriticalEdgesFunction
 161 val breakCriticalEdges = CriticalEdges.break
 162
 163 structure DeadBlocks =
 164 struct
 165
 166 fun eliminateFunction f =
 167    let
 168       val {args, blocks, mayInline, name, raises, returns, start} =
 169          Function.dest f
 170       val {get = isLive, set = setLive, rem} =
 171          Property.getSetOnce (Label.plist, Property.initConst false)
 172       val _ = Function.dfs (f, fn Block.T {label, ...} =>
 173                             (setLive (label, true)
 174                              ; fn () => ()))
 175       val f =
 176          if Vector.forall (blocks, isLive o Block.label)
 177             then f
 178          else
 179             let
 180                val blocks =
 181                   Vector.keepAll
 182                   (blocks, isLive o Block.label)
 183             in
 184                Function.new {args = args,
 185                              blocks = blocks,
 186                              mayInline = mayInline,
 187                              name = name,
 188                              raises = raises,
 189                              returns = returns,
 190                              start = start}
 191             end
 192        val _ = Vector.foreach (blocks, rem o Block.label)
 193    in
 194      f
 195    end
 196
 197 fun eliminate (Program.T {datatypes, globals, functions, main}) =
 198    Program.T {datatypes = datatypes,
 199               globals = globals,
 200               functions = List.revMap (functions, eliminateFunction),
 201               main = main}
 202 end
 203
 204 val eliminateDeadBlocksFunction = DeadBlocks.eliminateFunction
 205 val eliminateDeadBlocks = DeadBlocks.eliminate
 206
 207
 208 structure Order =
 209 struct
 210
 211 fun orderFunctions (p as Program.T {globals, datatypes, main, ...}) =
 212    let
 213       val functions = ref []
 214       val () =
 215          Program.dfs
 216          (p, fn f =>
 217           let
 218              val {args, mayInline, name, raises, returns, start, ...} =
 219                 Function.dest f
 220              val blocks = ref []
 221              val () =
 222                 Function.dfs
 223                 (f, fn b =>
 224                  (List.push (blocks, b)
 225                   ; fn () => ()))
 226              val f = Function.new {args = args,
 227                                    blocks = Vector.fromListRev (!blocks),
 228                                    mayInline = mayInline,
 229                                    name = name,
 230                                    raises = raises,
 231                                    returns = returns,
 232                                    start = start}
 233           in
 234              List.push (functions, f)
 235              ; fn () => ()
 236           end)
 237    in
 238       Program.T {datatypes = datatypes,
 239                  globals = globals,
 240                  functions = List.rev (!functions),
 241                  main = main}
 242    end
 243
 244 end
 245
 246 val orderFunctions = Order.orderFunctions
 247
 248
 249 structure Reverse =
 250 struct
 251
 252 fun reverseFunctions (Program.T {globals, datatypes, functions, main}) =
 253    Program.T {datatypes = datatypes,
 254               globals = globals,
 255               functions = List.rev functions,
 256               main = main}
 257 end
 258
 259 val reverseFunctions = Reverse.reverseFunctions
 260
 261 end