Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh |
2 | * Jagannathan, and Stephen Weeks. | |
3 | * Copyright (C) 1997-2000 NEC Research Institute. | |
4 | * | |
5 | * MLton is released under a BSD-style license. | |
6 | * See the file MLton-LICENSE for details. | |
7 | *) | |
8 | ||
9 | functor XmlSimplify (S: XML_SIMPLIFY_STRUCTS): XML_SIMPLIFY = | |
10 | struct | |
11 | ||
12 | open S | |
13 | ||
14 | structure SimplifyTypes = SimplifyTypes (structure Input = S | |
15 | structure Output = S) | |
16 | ||
17 | type pass = {name: string, | |
18 | doit: Program.t -> Program.t, | |
19 | execute: bool} | |
20 | ||
21 | val xmlPassesDefault = | |
22 | {name = "xmlShrink", doit = S.shrink, execute = true} :: | |
23 | {name = "xmlSimplifyTypes", doit = SimplifyTypes.simplifyTypes, execute = true} :: | |
24 | nil | |
25 | ||
26 | val xmlPassesMinimal = | |
27 | nil | |
28 | ||
29 | val xmlPasses : pass list ref = ref xmlPassesDefault | |
30 | ||
31 | local | |
32 | type passGen = string -> pass option | |
33 | ||
34 | fun mkSimplePassGen (name, doit): passGen = | |
35 | let val count = Counter.new 1 | |
36 | in fn s => if s = name | |
37 | then SOME {name = concat [name, "#", | |
38 | Int.toString (Counter.next count)], | |
39 | doit = doit, | |
40 | execute = true} | |
41 | else NONE | |
42 | end | |
43 | ||
44 | val passGens = | |
45 | (List.map([("xmlShrink", S.shrink), | |
46 | ("xmlSimplifyTypes", SimplifyTypes.simplifyTypes)], | |
47 | mkSimplePassGen)) | |
48 | in | |
49 | fun xmlPassesSetCustom s = | |
50 | Exn.withEscape | |
51 | (fn esc => | |
52 | (let val ss = String.split (s, #":") | |
53 | in | |
54 | xmlPasses := | |
55 | List.map(ss, fn s => | |
56 | case (List.peekMap (passGens, fn gen => gen s)) of | |
57 | NONE => esc (Result.No s) | |
58 | | SOME pass => pass) | |
59 | ; Result.Yes () | |
60 | end)) | |
61 | end | |
62 | ||
63 | val xmlPassesString = ref "default" | |
64 | val xmlPassesGet = fn () => !xmlPassesString | |
65 | val xmlPassesSet = fn s => | |
66 | let | |
67 | val _ = xmlPassesString := s | |
68 | in | |
69 | case s of | |
70 | "default" => (xmlPasses := xmlPassesDefault | |
71 | ; Result.Yes ()) | |
72 | | "minimal" => (xmlPasses := xmlPassesMinimal | |
73 | ; Result.Yes ()) | |
74 | | _ => xmlPassesSetCustom s | |
75 | end | |
76 | val _ = List.push (Control.optimizationPasses, | |
77 | {il = "xml", get = xmlPassesGet, set = xmlPassesSet}) | |
78 | ||
79 | fun pass ({name, doit}, p) = | |
80 | let | |
81 | val _ = | |
82 | let open Control | |
83 | in maybeSaveToFile | |
84 | ({name = name, | |
85 | suffix = "pre.xml"}, | |
86 | Control.No, p, Control.Layouts Program.layouts) | |
87 | end | |
88 | val p = | |
89 | Control.passTypeCheck | |
90 | {display = Control.Layouts Program.layouts, | |
91 | name = name, | |
92 | stats = Program.layoutStats, | |
93 | style = Control.No, | |
94 | suffix = "post.xml", | |
95 | thunk = fn () => doit p, | |
96 | typeCheck = typeCheck} | |
97 | in | |
98 | p | |
99 | end | |
100 | fun maybePass ({name, doit, execute}, p) = | |
101 | if List.foldr (!Control.executePasses, execute, fn ((re, new), old) => | |
102 | if Regexp.Compiled.matchesAll (re, name) | |
103 | then new | |
104 | else old) | |
105 | then pass ({name = name, doit = doit}, p) | |
106 | else (Control.messageStr (Control.Pass, name ^ " skipped"); p) | |
107 | fun simplify p = | |
108 | let | |
109 | fun simplify' p = | |
110 | List.fold | |
111 | (!xmlPasses, p, fn ({name, doit, execute}, p) => | |
112 | maybePass ({name = name, doit = doit, execute = execute}, p)) | |
113 | val p = simplify' p | |
114 | in | |
115 | p | |
116 | end | |
117 | ||
118 | val simplify = fn p => let | |
119 | (* Always want to type check the initial and final XML | |
120 | * programs, even if type checking is turned off, just | |
121 | * to catch bugs. | |
122 | *) | |
123 | val _ = typeCheck p | |
124 | val p' = simplify p | |
125 | val _ = typeCheck p' | |
126 | in | |
127 | p' | |
128 | end | |
129 | ||
130 | end |