Mercurial > urweb

annotate src/reduce.sml @ 557:0d3db8d6a586

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Building an application
author Adam Chlipala <adamc@hcoop.net>
date Tue, 09 Dec 2008 11:57:17 -0500
parents 6d6222e045b0
children 0dd40b6bfdf3
rev   line source
adamc@20 1 (* Copyright (c) 2008, Adam Chlipala
adamc@20 2 * All rights reserved.
adamc@20 3 *
adamc@20 4 * Redistribution and use in source and binary forms, with or without
adamc@20 5 * modification, are permitted provided that the following conditions are met:
adamc@20 6 *
adamc@20 7 * - Redistributions of source code must retain the above copyright notice,
adamc@20 8 * this list of conditions and the following disclaimer.
adamc@20 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@20 10 * this list of conditions and the following disclaimer in the documentation
adamc@20 11 * and/or other materials provided with the distribution.
adamc@20 12 * - The names of contributors may not be used to endorse or promote products
adamc@20 13 * derived from this software without specific prior written permission.
adamc@20 14 *
adamc@20 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@20 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@20 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@20 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@20 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@20 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@20 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@20 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@20 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@20 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@20 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@20 26 *)
adamc@20 27
adamc@20 28 (* Simplify a Core program algebraically *)
adamc@20 29
adamc@20 30 structure Reduce :> REDUCE = struct
adamc@20 31
adamc@20 32 open Core
adamc@20 33
adamc@508 34 structure IM = IntBinaryMap
adamc@20 35
adamc@508 36 datatype env_item =
adamc@508 37 UnknownC
adamc@508 38 | KnownC of con
adamc@21 39
adamc@508 40 | UnknownE
adamc@508 41 | KnownE of exp
adamc@20 42
adamc@508 43 | Lift of int * int
adamc@20 44
adamc@508 45 type env = env_item list
adamc@20 46
adamc@510 47 fun ei2s ei =
adamc@510 48 case ei of
adamc@510 49 UnknownC => "UC"
adamc@510 50 | KnownC _ => "KC"
adamc@510 51 | UnknownE => "UE"
adamc@510 52 | KnownE _ => "KE"
adamc@510 53 | Lift (n1, n2) => "(" ^ Int.toString n1 ^ ", " ^ Int.toString n2 ^ ")"
adamc@510 54
adamc@510 55 fun e2s env = String.concatWith " " (map ei2s env)
adamc@510 56
adamc@510 57 val deKnown = List.filter (fn KnownC _ => false
adamc@510 58 | KnownE _ => false
adamc@510 59 | _ => true)
adamc@510 60
adamc@508 61 fun conAndExp (namedC, namedE) =
adamc@508 62 let
adamc@508 63 fun con env (all as (c, loc)) =
adamc@510 64 ((*Print.prefaces "con" [("c", CorePrint.p_con CoreEnv.empty all)];*)
adamc@508 65 case c of
adamc@508 66 TFun (c1, c2) => (TFun (con env c1, con env c2), loc)
adamc@508 67 | TCFun (x, k, c2) => (TCFun (x, k, con (UnknownC :: env) c2), loc)
adamc@508 68 | TRecord c => (TRecord (con env c), loc)
adamc@215 69
adamc@508 70 | CRel n =>
adamc@508 71 let
adamc@510 72 fun find (n', env, nudge, lift) =
adamc@510 73 case env of
adamc@510 74 [] => raise Fail "Reduce.con: CRel"
adamc@510 75 | UnknownE :: rest => find (n', rest, nudge, lift)
adamc@510 76 | KnownE _ :: rest => find (n', rest, nudge, lift)
adamc@510 77 | Lift (lift', _) :: rest => find (n', rest, nudge + lift', lift + lift')
adamc@510 78 | UnknownC :: rest =>
adamc@510 79 if n' = 0 then
adamc@510 80 (CRel (n + nudge), loc)
adamc@510 81 else
adamc@510 82 find (n' - 1, rest, nudge, lift + 1)
adamc@510 83 | KnownC c :: rest =>
adamc@510 84 if n' = 0 then
adamc@510 85 con (Lift (lift, 0) :: rest) c
adamc@510 86 else
adamc@510 87 find (n' - 1, rest, nudge - 1, lift)
adamc@508 88 in
adamc@510 89 (*print (Int.toString n ^ ": " ^ e2s env ^ "\n");*)
adamc@510 90 find (n, env, 0, 0)
adamc@508 91 end
adamc@508 92 | CNamed n =>
adamc@508 93 (case IM.find (namedC, n) of
adamc@508 94 NONE => all
adamc@508 95 | SOME c => c)
adamc@508 96 | CFfi _ => all
adamc@508 97 | CApp (c1, c2) =>
adamc@508 98 let
adamc@508 99 val c1 = con env c1
adamc@508 100 val c2 = con env c2
adamc@508 101 in
adamc@508 102 case #1 c1 of
adamc@508 103 CAbs (_, _, b) =>
adamc@510 104 con (KnownC c2 :: deKnown env) b
adamc@215 105
adamc@511 106 | CApp ((CApp ((CFold _, _), f), _), i) =>
adamc@508 107 (case #1 c2 of
adamc@508 108 CRecord (_, []) => i
adamc@508 109 | CRecord (k, (x, c) :: rest) =>
adamc@510 110 con (deKnown env)
adamc@510 111 (CApp ((CApp ((CApp (f, x), loc), c), loc),
adamc@511 112 (CApp (c1,
adamc@510 113 (CRecord (k, rest), loc)), loc)), loc)
adamc@508 114 | _ => (CApp (c1, c2), loc))
adamc@20 115
adamc@508 116 | _ => (CApp (c1, c2), loc)
adamc@508 117 end
adamc@508 118 | CAbs (x, k, b) => (CAbs (x, k, con (UnknownC :: env) b), loc)
adamc@20 119
adamc@508 120 | CName _ => all
adamc@21 121
adamc@508 122 | CRecord (k, xcs) => (CRecord (k, map (fn (x, c) => (con env x, con env c)) xcs), loc)
adamc@508 123 | CConcat (c1, c2) =>
adamc@508 124 let
adamc@508 125 val c1 = con env c1
adamc@508 126 val c2 = con env c2
adamc@508 127 in
adamc@508 128 case (#1 c1, #1 c2) of
adamc@508 129 (CRecord (k, xcs1), CRecord (_, xcs2)) =>
adamc@508 130 (CRecord (k, xcs1 @ xcs2), loc)
adamc@508 131 | _ => (CConcat (c1, c2), loc)
adamc@508 132 end
adamc@508 133 | CFold _ => all
adamc@74 134
adamc@508 135 | CUnit => all
adamc@21 136
adamc@508 137 | CTuple cs => (CTuple (map (con env) cs), loc)
adamc@508 138 | CProj (c, n) =>
adamc@508 139 let
adamc@508 140 val c = con env c
adamc@508 141 in
adamc@508 142 case #1 c of
adamc@508 143 CTuple cs => List.nth (cs, n - 1)
adamc@508 144 | _ => (CProj (c, n), loc)
adamc@510 145 end)
adamc@22 146
adamc@509 147 fun patCon pc =
adamc@509 148 case pc of
adamc@509 149 PConVar _ => pc
adamc@509 150 | PConFfi {mod = m, datatyp, params, con = c, arg, kind} =>
adamc@509 151 PConFfi {mod = m, datatyp = datatyp, params = params, con = c,
adamc@509 152 arg = Option.map (con (map (fn _ => UnknownC) params)) arg,
adamc@509 153 kind = kind}
adamc@509 154
adamc@509 155
adamc@509 156 val k = (KType, ErrorMsg.dummySpan)
adamc@509 157 fun doPart e (this as (x, t), rest) =
adamc@509 158 ((x, (EField (e, x, {field = t, rest = (CRecord (k, rest), #2 t)}), #2 t), t),
adamc@509 159 this :: rest)
adamc@509 160
adamc@509 161 fun exp env (all as (e, loc)) =
adamc@510 162 ((*Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
adamc@510 163 ("env", Print.PD.string (e2s env))];*)
adamc@509 164 case e of
adamc@509 165 EPrim _ => all
adamc@509 166 | ERel n =>
adamc@509 167 let
adamc@510 168 fun find (n', env, nudge, liftC, liftE) =
adamc@510 169 case env of
adamc@510 170 [] => raise Fail "Reduce.exp: ERel"
adamc@510 171 | UnknownC :: rest => find (n', rest, nudge, liftC + 1, liftE)
adamc@510 172 | KnownC _ :: rest => find (n', rest, nudge, liftC, liftE)
adamc@510 173 | Lift (liftC', liftE') :: rest => find (n', rest, nudge + liftE',
adamc@510 174 liftC + liftC', liftE + liftE')
adamc@510 175 | UnknownE :: rest =>
adamc@510 176 if n' = 0 then
adamc@510 177 (ERel (n + nudge), loc)
adamc@510 178 else
adamc@510 179 find (n' - 1, rest, nudge, liftC, liftE + 1)
adamc@510 180 | KnownE e :: rest =>
adamc@510 181 if n' = 0 then
adamc@510 182 ((*print "SUBSTITUTING\n";*)
adamc@510 183 exp (Lift (liftC, liftE) :: rest) e)
adamc@510 184 else
adamc@510 185 find (n' - 1, rest, nudge - 1, liftC, liftE)
adamc@509 186 in
adamc@510 187 (*print (Int.toString n ^ ": " ^ e2s env ^ "\n");*)
adamc@510 188 find (n, env, 0, 0, 0)
adamc@509 189 end
adamc@509 190 | ENamed n =>
adamc@509 191 (case IM.find (namedE, n) of
adamc@509 192 NONE => all
adamc@509 193 | SOME e => e)
adamc@509 194 | ECon (dk, pc, cs, eo) => (ECon (dk, patCon pc,
adamc@509 195 map (con env) cs, Option.map (exp env) eo), loc)
adamc@509 196 | EFfi _ => all
adamc@509 197 | EFfiApp (m, f, es) => (EFfiApp (m, f, map (exp env) es), loc)
adamc@509 198
adamc@509 199 | EApp (e1, e2) =>
adamc@509 200 let
adamc@509 201 val e1 = exp env e1
adamc@509 202 val e2 = exp env e2
adamc@509 203 in
adamc@509 204 case #1 e1 of
adamc@510 205 EAbs (_, _, _, b) => exp (KnownE e2 :: deKnown env) b
adamc@509 206 | _ => (EApp (e1, e2), loc)
adamc@509 207 end
adamc@509 208
adamc@509 209 | EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (UnknownE :: env) e), loc)
adamc@509 210
adamc@509 211 | ECApp (e, c) =>
adamc@509 212 let
adamc@509 213 val e = exp env e
adamc@509 214 val c = con env c
adamc@509 215 in
adamc@509 216 case #1 e of
adamc@510 217 ECAbs (_, _, b) => exp (KnownC c :: deKnown env) b
adamc@511 218
adamc@511 219 | EApp ((EApp ((ECApp ((EFold _, _), _), _), f), _), i) =>
adamc@511 220 (case #1 c of
adamc@511 221 CRecord (_, []) => i
adamc@511 222 | CRecord (k, (nm, v) :: rest) =>
adamc@511 223 let
adamc@511 224 val rest = (CRecord (k, rest), loc)
adamc@511 225 in
adamc@511 226 exp (deKnown env)
adamc@511 227 (EApp ((ECApp ((ECApp ((ECApp (f, nm), loc), v), loc), rest), loc),
adamc@511 228 (ECApp (e, rest), loc)), loc)
adamc@511 229 end
adamc@511 230 | _ => (ECApp (e, c), loc))
adamc@511 231
adamc@509 232 | _ => (ECApp (e, c), loc)
adamc@509 233 end
adamc@509 234
adamc@509 235 | ECAbs (x, k, e) => (ECAbs (x, k, exp (UnknownC :: env) e), loc)
adamc@509 236
adamc@509 237 | ERecord xcs => (ERecord (map (fn (x, e, t) => (con env x, exp env e, con env t)) xcs), loc)
adamc@509 238 | EField (e, c, {field, rest}) =>
adamc@509 239 let
adamc@509 240 val e = exp env e
adamc@509 241 val c = con env c
adamc@509 242
adamc@509 243 fun default () = (EField (e, c, {field = con env field, rest = con env rest}), loc)
adamc@509 244 in
adamc@509 245 case (#1 e, #1 c) of
adamc@509 246 (ERecord xcs, CName x) =>
adamc@509 247 (case List.find (fn ((CName x', _), _, _) => x' = x | _ => false) xcs of
adamc@509 248 NONE => default ()
adamc@509 249 | SOME (_, e, _) => e)
adamc@509 250 | _ => default ()
adamc@509 251 end
adamc@509 252
adamc@509 253 | EConcat (e1, c1, e2, c2) =>
adamc@509 254 let
adamc@509 255 val e1 = exp env e1
adamc@509 256 val e2 = exp env e2
adamc@509 257 in
adamc@509 258 case (#1 e1, #1 e2) of
adamc@509 259 (ERecord xes1, ERecord xes2) => (ERecord (xes1 @ xes2), loc)
adamc@509 260 | _ =>
adamc@509 261 let
adamc@509 262 val c1 = con env c1
adamc@509 263 val c2 = con env c2
adamc@509 264 in
adamc@509 265 case (#1 c1, #1 c2) of
adamc@509 266 (CRecord (k, xcs1), CRecord (_, xcs2)) =>
adamc@509 267 let
adamc@509 268 val (xes1, rest) = ListUtil.foldlMap (doPart e1) [] xcs1
adamc@509 269 val (xes2, _) = ListUtil.foldlMap (doPart e2) rest xcs2
adamc@509 270 in
adamc@510 271 exp (deKnown env) (ERecord (xes1 @ xes2), loc)
adamc@509 272 end
adamc@509 273 | _ => (EConcat (e1, c1, e2, c2), loc)
adamc@509 274 end
adamc@509 275 end
adamc@509 276
adamc@509 277 | ECut (e, c, {field, rest}) =>
adamc@509 278 let
adamc@509 279 val e = exp env e
adamc@509 280 val c = con env c
adamc@509 281
adamc@509 282 fun default () =
adamc@509 283 let
adamc@509 284 val rest = con env rest
adamc@509 285 in
adamc@509 286 case #1 rest of
adamc@509 287 CRecord (k, xcs) =>
adamc@509 288 let
adamc@509 289 val (xes, _) = ListUtil.foldlMap (doPart e) [] xcs
adamc@509 290 in
adamc@510 291 exp (deKnown env) (ERecord xes, loc)
adamc@509 292 end
adamc@509 293 | _ => (ECut (e, c, {field = con env field, rest = rest}), loc)
adamc@509 294 end
adamc@509 295 in
adamc@509 296 case (#1 e, #1 c) of
adamc@509 297 (ERecord xes, CName x) =>
adamc@509 298 if List.all (fn ((CName _, _), _, _) => true | _ => false) xes then
adamc@509 299 (ERecord (List.filter (fn ((CName x', _), _, _) => x' <> x
adamc@509 300 | _ => raise Fail "Reduce: ECut") xes), loc)
adamc@509 301 else
adamc@509 302 default ()
adamc@509 303 | _ => default ()
adamc@509 304 end
adamc@509 305
adamc@509 306 | ECutMulti (e, c, {rest}) =>
adamc@509 307 let
adamc@509 308 val e = exp env e
adamc@509 309 val c = con env c
adamc@509 310
adamc@509 311 fun default () =
adamc@509 312 let
adamc@509 313 val rest = con env rest
adamc@509 314 in
adamc@509 315 case #1 rest of
adamc@509 316 CRecord (k, xcs) =>
adamc@509 317 let
adamc@509 318 val (xes, _) = ListUtil.foldlMap (doPart e) [] xcs
adamc@509 319 in
adamc@510 320 exp (deKnown env) (ERecord xes, loc)
adamc@509 321 end
adamc@509 322 | _ => (ECutMulti (e, c, {rest = rest}), loc)
adamc@509 323 end
adamc@509 324 in
adamc@509 325 case (#1 e, #1 c) of
adamc@509 326 (ERecord xes, CRecord (_, xcs)) =>
adamc@509 327 if List.all (fn ((CName _, _), _, _) => true | _ => false) xes
adamc@509 328 andalso List.all (fn ((CName _, _), _) => true | _ => false) xcs then
adamc@509 329 (ERecord (List.filter (fn ((CName x', _), _, _) =>
adamc@509 330 List.all (fn ((CName x, _), _) => x' <> x
adamc@509 331 | _ => raise Fail "Reduce: ECutMulti [1]") xcs
adamc@509 332 | _ => raise Fail "Reduce: ECutMulti [2]") xes), loc)
adamc@509 333 else
adamc@509 334 default ()
adamc@509 335 | _ => default ()
adamc@509 336 end
adamc@509 337
adamc@509 338 | EFold _ => all
adamc@509 339
adamc@509 340 | ECase (e, pes, {disc, result}) =>
adamc@509 341 let
adamc@509 342 fun patBinds (p, _) =
adamc@509 343 case p of
adamc@509 344 PWild => 0
adamc@509 345 | PVar _ => 1
adamc@509 346 | PPrim _ => 0
adamc@509 347 | PCon (_, _, _, NONE) => 0
adamc@509 348 | PCon (_, _, _, SOME p) => patBinds p
adamc@509 349 | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts
adamc@509 350
adamc@509 351 fun pat (all as (p, loc)) =
adamc@509 352 case p of
adamc@509 353 PWild => all
adamc@509 354 | PVar (x, t) => (PVar (x, con env t), loc)
adamc@509 355 | PPrim _ => all
adamc@509 356 | PCon (dk, pc, cs, po) =>
adamc@509 357 (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc)
adamc@509 358 | PRecord xpts => (PRecord (map (fn (x, p, t) => (x, pat p, con env t)) xpts), loc)
adamc@509 359 in
adamc@509 360 (ECase (exp env e,
adamc@509 361 map (fn (p, e) => (pat p,
adamc@509 362 exp (List.tabulate (patBinds p, fn _ => UnknownE) @ env) e))
adamc@509 363 pes, {disc = con env disc, result = con env result}), loc)
adamc@509 364 end
adamc@509 365
adamc@509 366 | EWrite e => (EWrite (exp env e), loc)
adamc@509 367 | EClosure (n, es) => (EClosure (n, map (exp env) es), loc)
adamc@509 368
adamc@510 369 | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc))
adamc@417 370 in
adamc@508 371 {con = con, exp = exp}
adamc@417 372 end
adamc@21 373
adamc@509 374 fun con namedC env c = #con (conAndExp (namedC, IM.empty)) env c
adamc@509 375 fun exp (namedC, namedE) env e = #exp (conAndExp (namedC, namedE)) env e
adamc@20 376
adamc@508 377 fun reduce file =
adamc@508 378 let
adamc@508 379 fun doDecl (d as (_, loc), st as (namedC, namedE)) =
adamc@508 380 case #1 d of
adamc@508 381 DCon (x, n, k, c) =>
adamc@508 382 let
adamc@509 383 val c = con namedC [] c
adamc@508 384 in
adamc@508 385 ((DCon (x, n, k, c), loc),
adamc@508 386 (IM.insert (namedC, n, c), namedE))
adamc@508 387 end
adamc@508 388 | DDatatype (x, n, ps, cs) =>
adamc@509 389 let
adamc@509 390 val env = map (fn _ => UnknownC) ps
adamc@509 391 in
adamc@509 392 ((DDatatype (x, n, ps, map (fn (x, n, co) => (x, n, Option.map (con namedC env) co)) cs), loc),
adamc@509 393 st)
adamc@509 394 end
adamc@508 395 | DVal (x, n, t, e, s) =>
adamc@508 396 let
adamc@509 397 val t = con namedC [] t
adamc@509 398 val e = exp (namedC, namedE) [] e
adamc@508 399 in
adamc@508 400 ((DVal (x, n, t, e, s), loc),
adamc@508 401 (namedC, IM.insert (namedE, n, e)))
adamc@508 402 end
adamc@508 403 | DValRec vis =>
adamc@509 404 ((DValRec (map (fn (x, n, t, e, s) => (x, n, con namedC [] t, exp (namedC, namedE) [] e, s)) vis), loc),
adamc@508 405 st)
adamc@508 406 | DExport _ => (d, st)
adamc@509 407 | DTable (s, n, c, s') => ((DTable (s, n, con namedC [] c, s'), loc), st)
adamc@508 408 | DSequence _ => (d, st)
adamc@508 409 | DDatabase _ => (d, st)
adamc@509 410 | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st)
adamc@20 411
adamc@508 412 val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty) file
adamc@508 413 in
adamc@508 414 file
adamc@508 415 end
adamc@20 416
adamc@20 417 end