Mercurial > urweb

annotate src/reduce.sml @ 623:588b9d16b00a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Start of kind polymorphism, up to the point where demo/hello elaborates with updated Basis/Top
author Adam Chlipala <adamc@hcoop.net>
date Sun, 22 Feb 2009 16:10:25 -0500
parents 8998114760c1
children 230654093b51
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@621 106 | CApp ((CMap (dom, ran), _), f) =>
adamc@508 107 (case #1 c2 of
adamc@621 108 CRecord (_, []) => (CRecord (ran, []), loc)
adamc@621 109 | CRecord (_, (x, c) :: rest) =>
adamc@510 110 con (deKnown env)
adamc@621 111 (CConcat ((CRecord (ran, [(x, (CApp (f, c), loc))]), loc),
adamc@621 112 (CApp (c1, (CRecord (dom, rest), loc)), loc)), loc)
adamc@508 113 | _ => (CApp (c1, c2), loc))
adamc@20 114
adamc@508 115 | _ => (CApp (c1, c2), loc)
adamc@508 116 end
adamc@508 117 | CAbs (x, k, b) => (CAbs (x, k, con (UnknownC :: env) b), loc)
adamc@20 118
adamc@508 119 | CName _ => all
adamc@21 120
adamc@508 121 | CRecord (k, xcs) => (CRecord (k, map (fn (x, c) => (con env x, con env c)) xcs), loc)
adamc@508 122 | CConcat (c1, c2) =>
adamc@508 123 let
adamc@508 124 val c1 = con env c1
adamc@508 125 val c2 = con env c2
adamc@508 126 in
adamc@508 127 case (#1 c1, #1 c2) of
adamc@508 128 (CRecord (k, xcs1), CRecord (_, xcs2)) =>
adamc@508 129 (CRecord (k, xcs1 @ xcs2), loc)
adamc@508 130 | _ => (CConcat (c1, c2), loc)
adamc@508 131 end
adamc@621 132 | CMap _ => all
adamc@74 133
adamc@508 134 | CUnit => all
adamc@21 135
adamc@508 136 | CTuple cs => (CTuple (map (con env) cs), loc)
adamc@508 137 | CProj (c, n) =>
adamc@508 138 let
adamc@508 139 val c = con env c
adamc@508 140 in
adamc@508 141 case #1 c of
adamc@508 142 CTuple cs => List.nth (cs, n - 1)
adamc@508 143 | _ => (CProj (c, n), loc)
adamc@510 144 end)
adamc@22 145
adamc@509 146 fun patCon pc =
adamc@509 147 case pc of
adamc@509 148 PConVar _ => pc
adamc@509 149 | PConFfi {mod = m, datatyp, params, con = c, arg, kind} =>
adamc@509 150 PConFfi {mod = m, datatyp = datatyp, params = params, con = c,
adamc@509 151 arg = Option.map (con (map (fn _ => UnknownC) params)) arg,
adamc@509 152 kind = kind}
adamc@509 153
adamc@509 154
adamc@509 155 val k = (KType, ErrorMsg.dummySpan)
adamc@509 156 fun doPart e (this as (x, t), rest) =
adamc@509 157 ((x, (EField (e, x, {field = t, rest = (CRecord (k, rest), #2 t)}), #2 t), t),
adamc@509 158 this :: rest)
adamc@509 159
adamc@509 160 fun exp env (all as (e, loc)) =
adamc@510 161 ((*Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
adamc@510 162 ("env", Print.PD.string (e2s env))];*)
adamc@509 163 case e of
adamc@509 164 EPrim _ => all
adamc@509 165 | ERel n =>
adamc@509 166 let
adamc@510 167 fun find (n', env, nudge, liftC, liftE) =
adamc@510 168 case env of
adamc@510 169 [] => raise Fail "Reduce.exp: ERel"
adamc@510 170 | UnknownC :: rest => find (n', rest, nudge, liftC + 1, liftE)
adamc@510 171 | KnownC _ :: rest => find (n', rest, nudge, liftC, liftE)
adamc@510 172 | Lift (liftC', liftE') :: rest => find (n', rest, nudge + liftE',
adamc@510 173 liftC + liftC', liftE + liftE')
adamc@510 174 | UnknownE :: rest =>
adamc@510 175 if n' = 0 then
adamc@510 176 (ERel (n + nudge), loc)
adamc@510 177 else
adamc@510 178 find (n' - 1, rest, nudge, liftC, liftE + 1)
adamc@510 179 | KnownE e :: rest =>
adamc@510 180 if n' = 0 then
adamc@510 181 ((*print "SUBSTITUTING\n";*)
adamc@510 182 exp (Lift (liftC, liftE) :: rest) e)
adamc@510 183 else
adamc@510 184 find (n' - 1, rest, nudge - 1, liftC, liftE)
adamc@509 185 in
adamc@510 186 (*print (Int.toString n ^ ": " ^ e2s env ^ "\n");*)
adamc@510 187 find (n, env, 0, 0, 0)
adamc@509 188 end
adamc@509 189 | ENamed n =>
adamc@509 190 (case IM.find (namedE, n) of
adamc@509 191 NONE => all
adamc@509 192 | SOME e => e)
adamc@509 193 | ECon (dk, pc, cs, eo) => (ECon (dk, patCon pc,
adamc@509 194 map (con env) cs, Option.map (exp env) eo), loc)
adamc@509 195 | EFfi _ => all
adamc@509 196 | EFfiApp (m, f, es) => (EFfiApp (m, f, map (exp env) es), loc)
adamc@509 197
adamc@509 198 | EApp (e1, e2) =>
adamc@509 199 let
adamc@509 200 val e1 = exp env e1
adamc@509 201 val e2 = exp env e2
adamc@509 202 in
adamc@509 203 case #1 e1 of
adamc@510 204 EAbs (_, _, _, b) => exp (KnownE e2 :: deKnown env) b
adamc@509 205 | _ => (EApp (e1, e2), loc)
adamc@509 206 end
adamc@509 207
adamc@509 208 | EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (UnknownE :: env) e), loc)
adamc@509 209
adamc@509 210 | ECApp (e, c) =>
adamc@509 211 let
adamc@509 212 val e = exp env e
adamc@509 213 val c = con env c
adamc@509 214 in
adamc@509 215 case #1 e of
adamc@510 216 ECAbs (_, _, b) => exp (KnownC c :: deKnown env) b
adamc@509 217 | _ => (ECApp (e, c), loc)
adamc@509 218 end
adamc@509 219
adamc@509 220 | ECAbs (x, k, e) => (ECAbs (x, k, exp (UnknownC :: env) e), loc)
adamc@509 221
adamc@509 222 | ERecord xcs => (ERecord (map (fn (x, e, t) => (con env x, exp env e, con env t)) xcs), loc)
adamc@509 223 | EField (e, c, {field, rest}) =>
adamc@509 224 let
adamc@509 225 val e = exp env e
adamc@509 226 val c = con env c
adamc@509 227
adamc@509 228 fun default () = (EField (e, c, {field = con env field, rest = con env rest}), loc)
adamc@509 229 in
adamc@509 230 case (#1 e, #1 c) of
adamc@509 231 (ERecord xcs, CName x) =>
adamc@509 232 (case List.find (fn ((CName x', _), _, _) => x' = x | _ => false) xcs of
adamc@509 233 NONE => default ()
adamc@509 234 | SOME (_, e, _) => e)
adamc@509 235 | _ => default ()
adamc@509 236 end
adamc@509 237
adamc@509 238 | EConcat (e1, c1, e2, c2) =>
adamc@509 239 let
adamc@509 240 val e1 = exp env e1
adamc@509 241 val e2 = exp env e2
adamc@509 242 in
adamc@509 243 case (#1 e1, #1 e2) of
adamc@509 244 (ERecord xes1, ERecord xes2) => (ERecord (xes1 @ xes2), loc)
adamc@509 245 | _ =>
adamc@509 246 let
adamc@509 247 val c1 = con env c1
adamc@509 248 val c2 = con env c2
adamc@509 249 in
adamc@509 250 case (#1 c1, #1 c2) of
adamc@509 251 (CRecord (k, xcs1), CRecord (_, xcs2)) =>
adamc@509 252 let
adamc@509 253 val (xes1, rest) = ListUtil.foldlMap (doPart e1) [] xcs1
adamc@509 254 val (xes2, _) = ListUtil.foldlMap (doPart e2) rest xcs2
adamc@509 255 in
adamc@510 256 exp (deKnown env) (ERecord (xes1 @ xes2), loc)
adamc@509 257 end
adamc@509 258 | _ => (EConcat (e1, c1, e2, c2), loc)
adamc@509 259 end
adamc@509 260 end
adamc@509 261
adamc@509 262 | ECut (e, c, {field, rest}) =>
adamc@509 263 let
adamc@509 264 val e = exp env e
adamc@509 265 val c = con env c
adamc@509 266
adamc@509 267 fun default () =
adamc@509 268 let
adamc@509 269 val rest = con env rest
adamc@509 270 in
adamc@509 271 case #1 rest of
adamc@509 272 CRecord (k, xcs) =>
adamc@509 273 let
adamc@509 274 val (xes, _) = ListUtil.foldlMap (doPart e) [] xcs
adamc@509 275 in
adamc@510 276 exp (deKnown env) (ERecord xes, loc)
adamc@509 277 end
adamc@509 278 | _ => (ECut (e, c, {field = con env field, rest = rest}), loc)
adamc@509 279 end
adamc@509 280 in
adamc@509 281 case (#1 e, #1 c) of
adamc@509 282 (ERecord xes, CName x) =>
adamc@509 283 if List.all (fn ((CName _, _), _, _) => true | _ => false) xes then
adamc@509 284 (ERecord (List.filter (fn ((CName x', _), _, _) => x' <> x
adamc@509 285 | _ => raise Fail "Reduce: ECut") xes), loc)
adamc@509 286 else
adamc@509 287 default ()
adamc@509 288 | _ => default ()
adamc@509 289 end
adamc@509 290
adamc@509 291 | ECutMulti (e, c, {rest}) =>
adamc@509 292 let
adamc@509 293 val e = exp env e
adamc@509 294 val c = con env c
adamc@509 295
adamc@509 296 fun default () =
adamc@509 297 let
adamc@509 298 val rest = con env rest
adamc@509 299 in
adamc@509 300 case #1 rest of
adamc@509 301 CRecord (k, xcs) =>
adamc@509 302 let
adamc@509 303 val (xes, _) = ListUtil.foldlMap (doPart e) [] xcs
adamc@509 304 in
adamc@510 305 exp (deKnown env) (ERecord xes, loc)
adamc@509 306 end
adamc@509 307 | _ => (ECutMulti (e, c, {rest = rest}), loc)
adamc@509 308 end
adamc@509 309 in
adamc@509 310 case (#1 e, #1 c) of
adamc@509 311 (ERecord xes, CRecord (_, xcs)) =>
adamc@509 312 if List.all (fn ((CName _, _), _, _) => true | _ => false) xes
adamc@509 313 andalso List.all (fn ((CName _, _), _) => true | _ => false) xcs then
adamc@509 314 (ERecord (List.filter (fn ((CName x', _), _, _) =>
adamc@509 315 List.all (fn ((CName x, _), _) => x' <> x
adamc@509 316 | _ => raise Fail "Reduce: ECutMulti [1]") xcs
adamc@509 317 | _ => raise Fail "Reduce: ECutMulti [2]") xes), loc)
adamc@509 318 else
adamc@509 319 default ()
adamc@509 320 | _ => default ()
adamc@509 321 end
adamc@509 322
adamc@509 323 | ECase (e, pes, {disc, result}) =>
adamc@509 324 let
adamc@509 325 fun patBinds (p, _) =
adamc@509 326 case p of
adamc@509 327 PWild => 0
adamc@509 328 | PVar _ => 1
adamc@509 329 | PPrim _ => 0
adamc@509 330 | PCon (_, _, _, NONE) => 0
adamc@509 331 | PCon (_, _, _, SOME p) => patBinds p
adamc@509 332 | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts
adamc@509 333
adamc@509 334 fun pat (all as (p, loc)) =
adamc@509 335 case p of
adamc@509 336 PWild => all
adamc@509 337 | PVar (x, t) => (PVar (x, con env t), loc)
adamc@509 338 | PPrim _ => all
adamc@509 339 | PCon (dk, pc, cs, po) =>
adamc@509 340 (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc)
adamc@509 341 | PRecord xpts => (PRecord (map (fn (x, p, t) => (x, pat p, con env t)) xpts), loc)
adamc@509 342 in
adamc@509 343 (ECase (exp env e,
adamc@509 344 map (fn (p, e) => (pat p,
adamc@509 345 exp (List.tabulate (patBinds p, fn _ => UnknownE) @ env) e))
adamc@509 346 pes, {disc = con env disc, result = con env result}), loc)
adamc@509 347 end
adamc@509 348
adamc@509 349 | EWrite e => (EWrite (exp env e), loc)
adamc@509 350 | EClosure (n, es) => (EClosure (n, map (exp env) es), loc)
adamc@509 351
adamc@607 352 | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc)
adamc@607 353
adamc@609 354 | EServerCall (n, es, e, t) => (EServerCall (n, map (exp env) es, exp env e, con env t), loc))
adamc@417 355 in
adamc@508 356 {con = con, exp = exp}
adamc@417 357 end
adamc@21 358
adamc@509 359 fun con namedC env c = #con (conAndExp (namedC, IM.empty)) env c
adamc@509 360 fun exp (namedC, namedE) env e = #exp (conAndExp (namedC, namedE)) env e
adamc@20 361
adamc@508 362 fun reduce file =
adamc@508 363 let
adamc@508 364 fun doDecl (d as (_, loc), st as (namedC, namedE)) =
adamc@508 365 case #1 d of
adamc@508 366 DCon (x, n, k, c) =>
adamc@508 367 let
adamc@509 368 val c = con namedC [] c
adamc@508 369 in
adamc@508 370 ((DCon (x, n, k, c), loc),
adamc@508 371 (IM.insert (namedC, n, c), namedE))
adamc@508 372 end
adamc@508 373 | DDatatype (x, n, ps, cs) =>
adamc@509 374 let
adamc@509 375 val env = map (fn _ => UnknownC) ps
adamc@509 376 in
adamc@509 377 ((DDatatype (x, n, ps, map (fn (x, n, co) => (x, n, Option.map (con namedC env) co)) cs), loc),
adamc@509 378 st)
adamc@509 379 end
adamc@508 380 | DVal (x, n, t, e, s) =>
adamc@508 381 let
adamc@509 382 val t = con namedC [] t
adamc@509 383 val e = exp (namedC, namedE) [] e
adamc@508 384 in
adamc@508 385 ((DVal (x, n, t, e, s), loc),
adamc@508 386 (namedC, IM.insert (namedE, n, e)))
adamc@508 387 end
adamc@508 388 | DValRec vis =>
adamc@509 389 ((DValRec (map (fn (x, n, t, e, s) => (x, n, con namedC [] t, exp (namedC, namedE) [] e, s)) vis), loc),
adamc@508 390 st)
adamc@508 391 | DExport _ => (d, st)
adamc@509 392 | DTable (s, n, c, s') => ((DTable (s, n, con namedC [] c, s'), loc), st)
adamc@508 393 | DSequence _ => (d, st)
adamc@508 394 | DDatabase _ => (d, st)
adamc@509 395 | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st)
adamc@20 396
adamc@508 397 val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty) file
adamc@508 398 in
adamc@508 399 file
adamc@508 400 end
adamc@20 401
adamc@20 402 end