Commit | Line | Data |
---|---|---|
7f918cf1 CE |
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 |