Mercurial > urweb

annotate src/specialize.sml @ 978:e1f3f1ea8cff

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
demo/increment works with interpretation
author Adam Chlipala <adamc@hcoop.net>
date Thu, 24 Sep 2009 10:42:59 -0400
parents 20a364c4a6dc
children 5b5c0b552f59
rev   line source
adamc@193 1 (* Copyright (c) 2008, Adam Chlipala
adamc@193 2 * All rights reserved.
adamc@193 3 *
adamc@193 4 * Redistribution and use in source and binary forms, with or without
adamc@193 5 * modification, are permitted provided that the following conditions are met:
adamc@193 6 *
adamc@193 7 * - Redistributions of source code must retain the above copyright notice,
adamc@193 8 * this list of conditions and the following disclaimer.
adamc@193 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@193 10 * this list of conditions and the following disclaimer in the documentation
adamc@193 11 * and/or other materials provided with the distribution.
adamc@193 12 * - The names of contributors may not be used to endorse or promote products
adamc@193 13 * derived from this software without specific prior written permission.
adamc@193 14 *
adamc@193 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@193 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@193 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@193 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@193 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@193 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@193 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@193 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@193 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@193 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@193 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@193 26 *)
adamc@193 27
adamc@315 28 (* Simplify a Core program by repeating polymorphic definitions of datatypes *)
adamc@193 29
adamc@193 30 structure Specialize :> SPECIALIZE = struct
adamc@193 31
adamc@193 32 open Core
adamc@193 33
adamc@193 34 structure E = CoreEnv
adamc@193 35 structure U = CoreUtil
adamc@193 36
adamc@193 37 val liftConInCon = E.liftConInCon
adamc@193 38 val subConInCon = E.subConInCon
adamc@193 39
adamc@193 40 structure CK = struct
adamc@193 41 type ord_key = con list
adamc@193 42 val compare = Order.joinL U.Con.compare
adamc@193 43 end
adamc@193 44
adamc@193 45 structure CM = BinaryMapFn(CK)
adamc@193 46 structure IM = IntBinaryMap
adamc@193 47
adamc@193 48 type datatyp' = {
adamc@193 49 name : int,
adamc@193 50 constructors : int IM.map
adamc@193 51 }
adamc@193 52
adamc@193 53 type datatyp = {
adamc@193 54 name : string,
adamc@193 55 params : int,
adamc@193 56 constructors : (string * int * con option) list,
adamc@193 57 specializations : datatyp' CM.map
adamc@193 58 }
adamc@193 59
adamc@193 60 type state = {
adamc@193 61 count : int,
adamc@193 62 datatypes : datatyp IM.map,
adamc@193 63 constructors : int IM.map,
adamc@846 64 decls : (string * int * string list * (string * int * con option) list) list
adamc@193 65 }
adamc@193 66
adamc@193 67 fun kind (k, st) = (k, st)
adamc@193 68
adamc@193 69 val isOpen = U.Con.exists {kind = fn _ => false,
adamc@193 70 con = fn c =>
adamc@193 71 case c of
adamc@193 72 CRel _ => true
adamc@193 73 | _ => false}
adamc@193 74
adamc@193 75 fun considerSpecialization (st : state, n, args, dt : datatyp) =
adamc@193 76 case CM.find (#specializations dt, args) of
adamc@193 77 SOME dt' => (#name dt', #constructors dt', st)
adamc@193 78 | NONE =>
adamc@193 79 let
adamc@194 80 (*val () = Print.prefaces "Args" [("args", Print.p_list (CorePrint.p_con CoreEnv.empty) args)]*)
adamc@194 81
adamc@193 82 val n' = #count st
adamc@193 83
adamc@194 84 val nxs = length args - 1
adamc@193 85 fun sub t = ListUtil.foldli (fn (i, arg, t) =>
adamc@194 86 subConInCon (nxs - i, arg) t) t args
adamc@193 87
adamc@193 88 val (cons, (count, cmap)) =
adamc@193 89 ListUtil.foldlMap (fn ((x, n, to), (count, cmap)) =>
adamc@193 90 let
adamc@193 91 val to = Option.map sub to
adamc@193 92 in
adamc@193 93 ((x, count, to),
adamc@193 94 (count + 1,
adamc@193 95 IM.insert (cmap, n, count)))
adamc@193 96 end) (n' + 1, IM.empty) (#constructors dt)
adamc@193 97
adamc@193 98 val st = {count = count,
adamc@193 99 datatypes = IM.insert (#datatypes st, n,
adamc@193 100 {name = #name dt,
adamc@193 101 params = #params dt,
adamc@193 102 constructors = #constructors dt,
adamc@193 103 specializations = CM.insert (#specializations dt,
adamc@193 104 args,
adamc@193 105 {name = n',
adamc@193 106 constructors = cmap})}),
adamc@193 107 constructors = #constructors st,
adamc@193 108 decls = #decls st}
adamc@193 109
adamc@193 110 val (cons, st) = ListUtil.foldlMap (fn ((x, n, NONE), st) => ((x, n, NONE), st)
adamc@193 111 | ((x, n, SOME t), st) =>
adamc@193 112 let
adamc@193 113 val (t, st) = specCon st t
adamc@193 114 in
adamc@193 115 ((x, n, SOME t), st)
adamc@193 116 end) st cons
adamc@193 117
adamc@846 118 val dt = (#name dt ^ "_s",
adamc@846 119 n',
adamc@846 120 [],
adamc@846 121 cons)
adamc@193 122 in
adamc@193 123 (n', cmap, {count = #count st,
adamc@193 124 datatypes = #datatypes st,
adamc@193 125 constructors = #constructors st,
adamc@846 126 decls = dt :: #decls st})
adamc@193 127 end
adamc@193 128
adamc@193 129 and con (c, st : state) =
adamc@193 130 let
adamc@193 131 fun findApp (c, args) =
adamc@193 132 case c of
adamc@193 133 CApp ((c', _), arg) => findApp (c', arg :: args)
adamc@193 134 | CNamed n => SOME (n, args)
adamc@193 135 | _ => NONE
adamc@193 136 in
adamc@193 137 case findApp (c, []) of
adamc@193 138 SOME (n, args as (_ :: _)) =>
adamc@193 139 if List.exists isOpen args then
adamc@193 140 (c, st)
adamc@193 141 else
adamc@193 142 (case IM.find (#datatypes st, n) of
adamc@193 143 NONE => (c, st)
adamc@193 144 | SOME dt =>
adamc@193 145 if length args <> #params dt then
adamc@193 146 (c, st)
adamc@193 147 else
adamc@193 148 let
adamc@193 149 val (n, _, st) = considerSpecialization (st, n, args, dt)
adamc@193 150 in
adamc@193 151 (CNamed n, st)
adamc@193 152 end)
adamc@193 153 | _ => (c, st)
adamc@193 154 end
adamc@193 155
adamc@193 156 and specCon st = U.Con.foldMap {kind = kind, con = con} st
adamc@193 157
adamc@193 158 fun pat (p, st) =
adamc@193 159 case #1 p of
adamc@193 160 PWild => (p, st)
adamc@193 161 | PVar _ => (p, st)
adamc@193 162 | PPrim _ => (p, st)
adamc@193 163 | PCon (dk, PConVar pn, args as (_ :: _), po) =>
adamc@193 164 let
adamc@193 165 val (po, st) =
adamc@193 166 case po of
adamc@193 167 NONE => (NONE, st)
adamc@193 168 | SOME p =>
adamc@193 169 let
adamc@193 170 val (p, st) = pat (p, st)
adamc@193 171 in
adamc@193 172 (SOME p, st)
adamc@193 173 end
adamc@193 174 val p = (PCon (dk, PConVar pn, args, po), #2 p)
adamc@193 175 in
adamc@193 176 if List.exists isOpen args then
adamc@193 177 (p, st)
adamc@193 178 else
adamc@193 179 case IM.find (#constructors st, pn) of
adamc@193 180 NONE => (p, st)
adamc@193 181 | SOME n =>
adamc@193 182 case IM.find (#datatypes st, n) of
adamc@193 183 NONE => (p, st)
adamc@193 184 | SOME dt =>
adamc@193 185 let
adamc@193 186 val (n, cmap, st) = considerSpecialization (st, n, args, dt)
adamc@193 187 in
adamc@193 188 case IM.find (cmap, pn) of
adamc@193 189 NONE => raise Fail "Specialize: Missing datatype constructor (pat)"
adamc@193 190 | SOME pn' => ((PCon (dk, PConVar pn', [], po), #2 p), st)
adamc@193 191 end
adamc@193 192 end
adamc@851 193 | PCon (dk, pc, args, SOME p') =>
adamc@851 194 let
adamc@851 195 val (p', st) = pat (p', st)
adamc@851 196 in
adamc@851 197 ((PCon (dk, pc, args, SOME p'), #2 p), st)
adamc@851 198 end
adamc@193 199 | PCon _ => (p, st)
adamc@193 200 | PRecord xps =>
adamc@193 201 let
adamc@193 202 val (xps, st) = ListUtil.foldlMap (fn ((x, p, t), st) =>
adamc@193 203 let
adamc@193 204 val (p, st) = pat (p, st)
adamc@193 205 in
adamc@193 206 ((x, p, t), st)
adamc@193 207 end)
adamc@193 208 st xps
adamc@193 209 in
adamc@193 210 ((PRecord xps, #2 p), st)
adamc@193 211 end
adamc@193 212
adamc@193 213 fun exp (e, st) =
adamc@193 214 case e of
adamc@193 215 ECon (dk, PConVar pn, args as (_ :: _), eo) =>
adamc@193 216 if List.exists isOpen args then
adamc@193 217 (e, st)
adamc@193 218 else
adamc@193 219 (case IM.find (#constructors st, pn) of
adamc@193 220 NONE => (e, st)
adamc@193 221 | SOME n =>
adamc@193 222 case IM.find (#datatypes st, n) of
adamc@193 223 NONE => (e, st)
adamc@193 224 | SOME dt =>
adamc@193 225 let
adamc@193 226 val (n, cmap, st) = considerSpecialization (st, n, args, dt)
adamc@193 227 in
adamc@193 228 case IM.find (cmap, pn) of
adamc@193 229 NONE => raise Fail "Specialize: Missing datatype constructor"
adamc@193 230 | SOME pn' => (ECon (dk, PConVar pn', [], eo), st)
adamc@193 231 end)
adamc@193 232 | ECase (e, pes, r) =>
adamc@193 233 let
adamc@193 234 val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
adamc@193 235 let
adamc@193 236 val (p, st) = pat (p, st)
adamc@193 237 in
adamc@193 238 ((p, e), st)
adamc@193 239 end) st pes
adamc@193 240 in
adamc@193 241 (ECase (e, pes, r), st)
adamc@193 242 end
adamc@193 243 | _ => (e, st)
adamc@193 244
adamc@193 245 fun decl (d, st) = (d, st)
adamc@193 246
adamc@193 247 val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl}
adamc@193 248
adamc@193 249 fun specialize file =
adamc@193 250 let
adamc@792 251 fun doDecl (d, st) =
adamc@194 252 let
adamc@194 253 (*val () = Print.preface ("decl:", CorePrint.p_decl CoreEnv.empty all)*)
adamc@792 254 val (d, st) = specDecl st d
adamc@194 255 in
adamc@792 256 case #1 d of
adamc@846 257 DDatatype dts =>
adamc@847 258 ((case #decls st of
adamc@847 259 [] => [d]
adamc@847 260 | dts' => [(DDatatype (dts' @ dts), #2 d)]),
adamc@792 261 {count = #count st,
adamc@846 262 datatypes = foldl (fn ((x, n, xs, xnts), dts) =>
adamc@846 263 IM.insert (dts, n,
adamc@846 264 {name = x,
adamc@846 265 params = length xs,
adamc@846 266 constructors = xnts,
adamc@846 267 specializations = CM.empty}))
adamc@846 268 (#datatypes st) dts,
adamc@846 269 constructors = foldl (fn ((x, n, xs, xnts), cs) =>
adamc@846 270 foldl (fn ((_, n', _), constructors) =>
adamc@846 271 IM.insert (constructors, n', n))
adamc@846 272 cs xnts)
adamc@846 273 (#constructors st) dts,
adamc@792 274 decls = []})
adamc@194 275 | _ =>
adamc@847 276 (case #decls st of
adamc@847 277 [] => [d]
adamc@847 278 | dts => [(DDatatype dts, #2 d), d],
adamc@792 279 {count = #count st,
adamc@792 280 datatypes = #datatypes st,
adamc@792 281 constructors = #constructors st,
adamc@792 282 decls = []})
adamc@194 283 end
adamc@193 284
adamc@193 285 val (ds, _) = ListUtil.foldlMapConcat doDecl
adamc@193 286 {count = U.File.maxName file + 1,
adamc@193 287 datatypes = IM.empty,
adamc@193 288 constructors = IM.empty,
adamc@193 289 decls = []} file
adamc@193 290 in
adamc@193 291 ds
adamc@193 292 end
adamc@193 293
adamc@193 294 end