Mercurial > urweb

annotate src/specialize.sml @ 193:8a70e2919e86

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Specialization of single-parameter datatypes
author Adam Chlipala <adamc@hcoop.net>
date Fri, 08 Aug 2008 17:55:51 -0400
parents
children df5fd8f6913a
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@193 28 (* Simplify a Core program algebraically *)
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@193 64 decls : decl 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@193 80 val n' = #count st
adamc@193 81
adamc@193 82 fun sub t = ListUtil.foldli (fn (i, arg, t) =>
adamc@193 83 subConInCon (i, arg) t) t args
adamc@193 84
adamc@193 85 val (cons, (count, cmap)) =
adamc@193 86 ListUtil.foldlMap (fn ((x, n, to), (count, cmap)) =>
adamc@193 87 let
adamc@193 88 val to = Option.map sub to
adamc@193 89 in
adamc@193 90 ((x, count, to),
adamc@193 91 (count + 1,
adamc@193 92 IM.insert (cmap, n, count)))
adamc@193 93 end) (n' + 1, IM.empty) (#constructors dt)
adamc@193 94
adamc@193 95 val st = {count = count,
adamc@193 96 datatypes = IM.insert (#datatypes st, n,
adamc@193 97 {name = #name dt,
adamc@193 98 params = #params dt,
adamc@193 99 constructors = #constructors dt,
adamc@193 100 specializations = CM.insert (#specializations dt,
adamc@193 101 args,
adamc@193 102 {name = n',
adamc@193 103 constructors = cmap})}),
adamc@193 104 constructors = #constructors st,
adamc@193 105 decls = #decls st}
adamc@193 106
adamc@193 107 val (cons, st) = ListUtil.foldlMap (fn ((x, n, NONE), st) => ((x, n, NONE), st)
adamc@193 108 | ((x, n, SOME t), st) =>
adamc@193 109 let
adamc@193 110 val (t, st) = specCon st t
adamc@193 111 in
adamc@193 112 ((x, n, SOME t), st)
adamc@193 113 end) st cons
adamc@193 114
adamc@193 115 val d = (DDatatype (#name dt ^ "_s",
adamc@193 116 n',
adamc@193 117 [],
adamc@193 118 cons), #2 (List.hd args))
adamc@193 119 in
adamc@193 120 (n', cmap, {count = #count st,
adamc@193 121 datatypes = #datatypes st,
adamc@193 122 constructors = #constructors st,
adamc@193 123 decls = d :: #decls st})
adamc@193 124 end
adamc@193 125
adamc@193 126 and con (c, st : state) =
adamc@193 127 let
adamc@193 128 fun findApp (c, args) =
adamc@193 129 case c of
adamc@193 130 CApp ((c', _), arg) => findApp (c', arg :: args)
adamc@193 131 | CNamed n => SOME (n, args)
adamc@193 132 | _ => NONE
adamc@193 133 in
adamc@193 134 case findApp (c, []) of
adamc@193 135 SOME (n, args as (_ :: _)) =>
adamc@193 136 if List.exists isOpen args then
adamc@193 137 (c, st)
adamc@193 138 else
adamc@193 139 (case IM.find (#datatypes st, n) of
adamc@193 140 NONE => (c, st)
adamc@193 141 | SOME dt =>
adamc@193 142 if length args <> #params dt then
adamc@193 143 (c, st)
adamc@193 144 else
adamc@193 145 let
adamc@193 146 val (n, _, st) = considerSpecialization (st, n, args, dt)
adamc@193 147 in
adamc@193 148 (CNamed n, st)
adamc@193 149 end)
adamc@193 150 | _ => (c, st)
adamc@193 151 end
adamc@193 152
adamc@193 153 and specCon st = U.Con.foldMap {kind = kind, con = con} st
adamc@193 154
adamc@193 155 fun pat (p, st) =
adamc@193 156 case #1 p of
adamc@193 157 PWild => (p, st)
adamc@193 158 | PVar _ => (p, st)
adamc@193 159 | PPrim _ => (p, st)
adamc@193 160 | PCon (dk, PConVar pn, args as (_ :: _), po) =>
adamc@193 161 let
adamc@193 162 val (po, st) =
adamc@193 163 case po of
adamc@193 164 NONE => (NONE, st)
adamc@193 165 | SOME p =>
adamc@193 166 let
adamc@193 167 val (p, st) = pat (p, st)
adamc@193 168 in
adamc@193 169 (SOME p, st)
adamc@193 170 end
adamc@193 171 val p = (PCon (dk, PConVar pn, args, po), #2 p)
adamc@193 172 in
adamc@193 173 if List.exists isOpen args then
adamc@193 174 (p, st)
adamc@193 175 else
adamc@193 176 case IM.find (#constructors st, pn) of
adamc@193 177 NONE => (p, st)
adamc@193 178 | SOME n =>
adamc@193 179 case IM.find (#datatypes st, n) of
adamc@193 180 NONE => (p, st)
adamc@193 181 | SOME dt =>
adamc@193 182 let
adamc@193 183 val (n, cmap, st) = considerSpecialization (st, n, args, dt)
adamc@193 184 in
adamc@193 185 case IM.find (cmap, pn) of
adamc@193 186 NONE => raise Fail "Specialize: Missing datatype constructor (pat)"
adamc@193 187 | SOME pn' => ((PCon (dk, PConVar pn', [], po), #2 p), st)
adamc@193 188 end
adamc@193 189 end
adamc@193 190 | PCon _ => (p, st)
adamc@193 191 | PRecord xps =>
adamc@193 192 let
adamc@193 193 val (xps, st) = ListUtil.foldlMap (fn ((x, p, t), st) =>
adamc@193 194 let
adamc@193 195 val (p, st) = pat (p, st)
adamc@193 196 in
adamc@193 197 ((x, p, t), st)
adamc@193 198 end)
adamc@193 199 st xps
adamc@193 200 in
adamc@193 201 ((PRecord xps, #2 p), st)
adamc@193 202 end
adamc@193 203
adamc@193 204 fun exp (e, st) =
adamc@193 205 case e of
adamc@193 206 ECon (dk, PConVar pn, args as (_ :: _), eo) =>
adamc@193 207 if List.exists isOpen args then
adamc@193 208 (e, st)
adamc@193 209 else
adamc@193 210 (case IM.find (#constructors st, pn) of
adamc@193 211 NONE => (e, st)
adamc@193 212 | SOME n =>
adamc@193 213 case IM.find (#datatypes st, n) of
adamc@193 214 NONE => (e, st)
adamc@193 215 | SOME dt =>
adamc@193 216 let
adamc@193 217 val (n, cmap, st) = considerSpecialization (st, n, args, dt)
adamc@193 218 in
adamc@193 219 case IM.find (cmap, pn) of
adamc@193 220 NONE => raise Fail "Specialize: Missing datatype constructor"
adamc@193 221 | SOME pn' => (ECon (dk, PConVar pn', [], eo), st)
adamc@193 222 end)
adamc@193 223 | ECase (e, pes, r) =>
adamc@193 224 let
adamc@193 225 val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
adamc@193 226 let
adamc@193 227 val (p, st) = pat (p, st)
adamc@193 228 in
adamc@193 229 ((p, e), st)
adamc@193 230 end) st pes
adamc@193 231 in
adamc@193 232 (ECase (e, pes, r), st)
adamc@193 233 end
adamc@193 234 | _ => (e, st)
adamc@193 235
adamc@193 236 fun decl (d, st) = (d, st)
adamc@193 237
adamc@193 238 val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl}
adamc@193 239
adamc@193 240 fun specialize file =
adamc@193 241 let
adamc@193 242 fun doDecl (all as (d, _), st : state) =
adamc@193 243 case d of
adamc@193 244 DDatatype (x, n, xs, xnts) =>
adamc@193 245 ([all], {count = #count st,
adamc@193 246 datatypes = IM.insert (#datatypes st, n,
adamc@193 247 {name = x,
adamc@193 248 params = length xs,
adamc@193 249 constructors = xnts,
adamc@193 250 specializations = CM.empty}),
adamc@193 251 constructors = foldl (fn ((_, n', _), constructors) =>
adamc@193 252 IM.insert (constructors, n', n))
adamc@193 253 (#constructors st) xnts,
adamc@193 254 decls = []})
adamc@193 255 | _ =>
adamc@193 256 let
adamc@193 257 val (d, st) = specDecl st all
adamc@193 258 in
adamc@193 259 (rev (d :: #decls st),
adamc@193 260 {count = #count st,
adamc@193 261 datatypes = #datatypes st,
adamc@193 262 constructors = #constructors st,
adamc@193 263 decls = []})
adamc@193 264 end
adamc@193 265
adamc@193 266 val (ds, _) = ListUtil.foldlMapConcat doDecl
adamc@193 267 {count = U.File.maxName file + 1,
adamc@193 268 datatypes = IM.empty,
adamc@193 269 constructors = IM.empty,
adamc@193 270 decls = []} file
adamc@193 271 in
adamc@193 272 ds
adamc@193 273 end
adamc@193 274
adamc@193 275
adamc@193 276 end