mlton/ssa/simplify2.fun

   1 (* Copyright (C) 2017 Matthew Fluet.
   2  * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  * Copyright (C) 1997-2000 NEC Research Institute.
   5  *
   6  * MLton is released under a BSD-style license.
   7  * See the file MLton-LICENSE for details.
   8  *)
   9
  10 functor Simplify2 (S: SIMPLIFY2_STRUCTS): SIMPLIFY2 =
  11 struct
  12
  13 open S
  14
  15 structure DeepFlatten = DeepFlatten (S)
  16 structure Profile2 = Profile2 (S)
  17 structure RefFlatten = RefFlatten (S)
  18 structure RemoveUnused2 = RemoveUnused2 (S)
  19 structure Zone = Zone (S)
  20
  21 type pass = {name: string,
  22              doit: Program.t -> Program.t,
  23              execute: bool}
  24
  25 val ssa2PassesDefault =
  26    {name = "deepFlatten", doit = DeepFlatten.transform2, execute = true} ::
  27    {name = "refFlatten", doit = RefFlatten.transform2, execute = true} ::
  28    {name = "removeUnused5", doit = RemoveUnused2.transform2, execute = true} ::
  29    {name = "zone", doit = Zone.transform2, execute = true} ::
  30    nil
  31
  32 val ssa2PassesMinimal =
  33    nil
  34
  35 val ssa2Passes : pass list ref = ref ssa2PassesDefault
  36
  37 local
  38    type passGen = string -> pass option
  39
  40    fun mkSimplePassGen (name, doit): passGen =
  41       let val count = Counter.new 1
  42       in fn s => if s = name
  43                     then SOME {name = concat [name, "#",
  44                                               Int.toString (Counter.next count)],
  45                                doit = doit,
  46                                execute = true}
  47                     else NONE
  48       end
  49
  50
  51    val passGens =
  52       List.map([("deepFlatten", DeepFlatten.transform2),
  53                 ("refFlatten", RefFlatten.transform2),
  54                 ("removeUnused", RemoveUnused2.transform2),
  55                 ("zone", Zone.transform2),
  56                 ("ssa2AddProfile", Profile2.addProfile),
  57                 ("ssa2DropProfile", Profile2.dropProfile),
  58                 ("ssa2EliminateDeadBlocks", S.eliminateDeadBlocks),
  59                 ("ssa2OrderFunctions", S.orderFunctions),
  60                 ("ssa2ReverseFunctions", S.reverseFunctions),
  61                 ("ssa2Shrink", S.shrink)],
  62                mkSimplePassGen)
  63 in
  64    fun ssa2PassesSetCustom s =
  65       Exn.withEscape
  66       (fn esc =>
  67        (let val ss = String.split (s, #":")
  68         in
  69            ssa2Passes :=
  70            List.map(ss, fn s =>
  71                     case (List.peekMap (passGens, fn gen => gen s)) of
  72                        NONE => esc (Result.No s)
  73                      | SOME pass => pass)
  74            ; Result.Yes ()
  75         end))
  76 end
  77
  78 val ssa2PassesString = ref "default"
  79 val ssa2PassesGet = fn () => !ssa2PassesString
  80 val ssa2PassesSet = fn s =>
  81    let
  82       val _ = ssa2PassesString := s
  83    in
  84       case s of
  85          "default" => (ssa2Passes := ssa2PassesDefault
  86                        ; Result.Yes ())
  87        | "minimal" => (ssa2Passes := ssa2PassesMinimal
  88                        ; Result.Yes ())
  89        | _ => ssa2PassesSetCustom s
  90    end
  91 val _ = List.push (Control.optimizationPasses,
  92                    {il = "ssa2", get = ssa2PassesGet, set = ssa2PassesSet})
  93
  94 fun pass ({name, doit, midfix}, p) =
  95    let
  96       val _ =
  97          let open Control
  98          in maybeSaveToFile
  99             ({name = name,
 100               suffix = midfix ^ "pre.ssa2"},
 101              Control.No, p, Control.Layouts Program.layouts)
 102          end
 103       val p =
 104          Control.passTypeCheck
 105          {display = Control.Layouts Program.layouts,
 106           name = name,
 107           stats = Program.layoutStats,
 108           style = Control.No,
 109           suffix = midfix ^ "post.ssa2",
 110           thunk = fn () => doit p,
 111           typeCheck = typeCheck}
 112    in
 113       p
 114    end
 115 fun maybePass ({name, doit, execute, midfix}, p) =
 116    if List.foldr (!Control.executePasses, execute, fn ((re, new), old) =>
 117                   if Regexp.Compiled.matchesAll (re, name)
 118                      then new
 119                      else old)
 120       then pass ({name = name, doit = doit, midfix = midfix}, p)
 121       else (Control.messageStr (Control.Pass, name ^ " skipped"); p)
 122
 123 fun simplify p =
 124    let
 125       fun simplify' n p =
 126          let
 127             val midfix = if !Control.loopSsa2Passes = 1
 128                             then ""
 129                          else concat [Int.toString n, "."]
 130          in
 131             if n = !Control.loopSsa2Passes
 132                then p
 133             else simplify'
 134                  (n + 1)
 135                  (List.fold
 136                   (!ssa2Passes, p, fn ({name, doit, execute}, p) =>
 137                    maybePass ({name = name, doit = doit, execute = execute, midfix = midfix}, p)))
 138          end
 139       val p = simplify' 0 p
 140    in
 141       p
 142    end
 143
 144 val simplify = fn p => let
 145                          (* Always want to type check the initial and final SSA
 146                           * programs, even if type checking is turned off, just
 147                           * to catch bugs.
 148                           *)
 149                          val _ = typeCheck p
 150                          val p = simplify p
 151                          val p =
 152                             if !Control.profile <> Control.ProfileNone
 153                                andalso !Control.profileIL = Control.ProfileSSA2
 154                                then pass ({name = "ssa2AddProfile",
 155                                            doit = Profile2.addProfile,
 156                                            midfix = ""}, p)
 157                             else p
 158                          val p = maybePass ({name = "ssa2OrderFunctions",
 159                                              doit = S.orderFunctions,
 160                                              execute = true,
 161                                              midfix = ""}, p)
 162                          val _ = typeCheck p
 163                        in
 164                          p
 165                        end
 166 end