1 (* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
2 * Jagannathan, and Stephen Weeks.
3 * Copyright (C) 1997-2000 NEC Research Institute.
5 * MLton is released under a BSD-style license.
6 * See the file MLton-LICENSE for details.
9 functor SxmlSimplify (S: SXML_SIMPLIFY_STRUCTS): SXML_SIMPLIFY =
14 structure ImplementExceptions = ImplementExceptions (open S)
15 structure ImplementSuffix = ImplementSuffix (open S)
16 structure Polyvariance = Polyvariance (open S)
17 (* structure Uncurry = Uncurry (open S) *)
18 structure CPSTransform = CPSTransform (open S)
20 fun polyvariance (hofo, rounds, small, product) p =
22 (Control.polyvariance,
23 SOME {hofo = hofo, rounds = rounds, small = small, product = product},
24 fn () => Polyvariance.transform p)
26 type pass = {name: string,
27 doit: Program.t -> Program.t,
30 val sxmlPassesDefault =
31 {name = "sxmlShrink1", doit = S.shrink, execute = true} ::
32 {name = "implementSuffix", doit = ImplementSuffix.transform, execute = true} ::
33 {name = "sxmlShrink2", doit = S.shrink, execute = true} ::
34 {name = "implementExceptions", doit = ImplementExceptions.transform, execute = true} ::
35 {name = "sxmlShrink3", doit = S.shrink, execute = true} ::
36 (* {name = "uncurry", doit = Uncurry.transform, execute = true} :: *)
37 (* {name = "sxmlShrink4", doit = S.shrink, execute = true} :: *)
38 {name = "polyvariance", doit = Polyvariance.transform, execute = true} ::
39 {name = "sxmlShrink4", doit = S.shrink, execute = true} ::
42 val sxmlPassesCpsTransform =
44 {name = "cpsTransform", doit = CPSTransform.transform, execute = true} ::
45 {name = "cpsSxmlShrink5", doit = S.shrink, execute = true} ::
46 {name = "cpsPolyvariance", doit = Polyvariance.transform, execute = true} ::
47 {name = "cpsSxmlShrink6", doit = S.shrink, execute = true} ::
50 val sxmlPassesMinimal =
51 {name = "implementSuffix", doit = ImplementSuffix.transform, execute = true} ::
52 {name = "implementExceptions", doit = ImplementExceptions.transform, execute = true} ::
55 val sxmlPasses : pass list ref = ref sxmlPassesDefault
58 type passGen = string -> pass option
60 fun mkSimplePassGen (name, doit): passGen =
61 let val count = Counter.new 1
62 in fn s => if s = name
63 then SOME {name = name ^ "#" ^
64 (Int.toString (Counter.next count)),
70 val polyvariancePassGen =
72 val count = Counter.new 1
76 else if String.sub (s, 0) = #"("
77 andalso String.sub (s, String.size s - 1)= #")"
79 val s = String.dropFirst (String.dropLast s)
81 case List.fold (String.split (s, #","), SOME [],
82 fn (s,SOME nums) => (case Int.fromString s of
83 SOME i => SOME (i::nums)
85 | (_, NONE) => NONE) of
86 SOME (l as _::_) => SOME (List.rev l)
92 if String.hasPrefix (s, {prefix = "polyvariance"})
94 fun mk (hofo, rounds, small, product) =
95 SOME {name = concat ["polyvariance(",
96 Bool.toString hofo, ",",
97 Int.toString rounds, ",",
98 Int.toString small, ",",
99 Int.toString product, ")#",
100 Int.toString (Counter.next count)],
101 doit = polyvariance (hofo, rounds, small, product),
103 val s = String.dropPrefix (s, String.size "polyvariance")
106 SOME [] => mk (true, 2, 30, 300)
107 | SOME [hofo, rounds, small, product] =>
108 mk (hofo <> 0, rounds, small, product)
115 polyvariancePassGen ::
116 (List.map([("sxmlShrink", S.shrink),
117 ("implementExceptions", ImplementExceptions.transform),
118 ("implementSuffix", ImplementSuffix.transform)],
121 fun sxmlPassesSetCustom s =
124 (let val ss = String.split (s, #":")
128 case (List.peekMap (passGens, fn gen => gen s)) of
129 NONE => esc (Result.No s)
135 val sxmlPassesString = ref "default"
136 val sxmlPassesGet = fn () => !sxmlPassesString
137 val sxmlPassesSet = fn s =>
139 val _ = sxmlPassesString := s
142 "default" => (sxmlPasses := sxmlPassesDefault
144 | "cpsTransform" => (sxmlPasses := sxmlPassesCpsTransform
146 | "minimal" => (sxmlPasses := sxmlPassesMinimal
148 | _ => sxmlPassesSetCustom s
150 val _ = List.push (Control.optimizationPasses,
151 {il = "sxml", get = sxmlPassesGet, set = sxmlPassesSet})
153 fun pass ({name, doit}, p) =
159 suffix = "pre.sxml"},
160 Control.No, p, Control.Layouts Program.layouts)
163 Control.passTypeCheck
164 {display = Control.Layouts Program.layouts,
166 stats = Program.layoutStats,
168 suffix = "post.sxml",
169 thunk = fn () => doit p,
170 typeCheck = typeCheck}
174 fun maybePass ({name, doit, execute}, p) =
175 if List.foldr (!Control.executePasses, execute, fn ((re, new), old) =>
176 if Regexp.Compiled.matchesAll (re, name)
179 then pass ({name = name, doit = doit}, p)
180 else (Control.messageStr (Control.Pass, name ^ " skipped"); p)
185 (!sxmlPasses, p, fn ({name, doit, execute}, p) =>
186 maybePass ({name = name, doit = doit, execute = execute}, p))
192 val simplify = fn p => let
193 (* Always want to type check the initial and final XML
194 * programs, even if type checking is turned off, just