| 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 |