mlton/ssa/prepasses2.fun

   1 (* Copyright (C) 2005-2007 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  *
   4  * MLton is released under a BSD-style license.
   5  * See the file MLton-LICENSE for details.
   6  *)
   7
   8 functor PrePasses2 (S: PREPASSES2_STRUCTS): PREPASSES2 =
   9 struct
  10
  11 open S
  12
  13 structure DeadBlocks =
  14 struct
  15
  16 fun eliminateFunction f =
  17    let
  18       val {args, blocks, mayInline, name, raises, returns, start} =
  19          Function.dest f
  20       val {get = isLive, set = setLive, rem} =
  21          Property.getSetOnce (Label.plist, Property.initConst false)
  22       val _ = Function.dfs (f, fn Block.T {label, ...} =>
  23                             (setLive (label, true)
  24                              ; fn () => ()))
  25       val f =
  26          if Vector.forall (blocks, isLive o Block.label)
  27             then f
  28          else
  29             let
  30                val blocks =
  31                   Vector.keepAll
  32                   (blocks, isLive o Block.label)
  33             in
  34                Function.new {args = args,
  35                              blocks = blocks,
  36                              mayInline = mayInline,
  37                              name = name,
  38                              raises = raises,
  39                              returns = returns,
  40                              start = start}
  41             end
  42        val _ = Vector.foreach (blocks, rem o Block.label)
  43    in
  44      f
  45    end
  46
  47 fun eliminate (Program.T {datatypes, globals, functions, main}) =
  48    Program.T {datatypes = datatypes,
  49               globals = globals,
  50               functions = List.revMap (functions, eliminateFunction),
  51               main = main}
  52 end
  53
  54 val eliminateDeadBlocksFunction = DeadBlocks.eliminateFunction
  55 (* quell unused warning *)
  56 val _ = eliminateDeadBlocksFunction
  57 val eliminateDeadBlocks = DeadBlocks.eliminate
  58
  59
  60 structure Order =
  61 struct
  62
  63 fun orderFunctions (p as Program.T {globals, datatypes, main, ...}) =
  64    let
  65       val functions = ref []
  66       val () =
  67          Program.dfs
  68          (p, fn f =>
  69           let
  70              val {args, mayInline, name, raises, returns, start, ...} =
  71                 Function.dest f
  72              val blocks = ref []
  73              val () =
  74                 Function.dfs
  75                 (f, fn b =>
  76                  (List.push (blocks, b)
  77                   ; fn () => ()))
  78              val f = Function.new {args = args,
  79                                    blocks = Vector.fromListRev (!blocks),
  80                                    mayInline = mayInline,
  81                                    name = name,
  82                                    raises = raises,
  83                                    returns = returns,
  84                                    start = start}
  85           in
  86              List.push (functions, f)
  87              ; fn () => ()
  88           end)
  89    in
  90       Program.T {datatypes = datatypes,
  91                  globals = globals,
  92                  functions = List.rev (!functions),
  93                  main = main}
  94    end
  95
  96 end
  97
  98 val orderFunctions = Order.orderFunctions
  99
 100
 101 structure Reverse =
 102 struct
 103
 104 fun reverseFunctions (Program.T {globals, datatypes, functions, main}) =
 105    Program.T {datatypes = datatypes,
 106               globals = globals,
 107               functions = List.rev functions,
 108               main = main}
 109 end
 110
 111 val reverseFunctions = Reverse.reverseFunctions
 112
 113 end