Mercurial > urweb

annotate src/reduce.sml @ 510:c644ec94866d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix environments for repeat visits for exp reduction
author Adam Chlipala <adamc@hcoop.net>
date Wed, 26 Nov 2008 14:51:52 -0500
parents 140c68046598
children 6d6222e045b0
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@508 106 | CApp ((CApp (fold as (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@510 112 (CApp ((CApp ((CApp (fold, f), loc), i), loc),
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@509 218 | _ => (ECApp (e, c), loc)
adamc@509 219 end
adamc@509 220
adamc@509 221 | ECAbs (x, k, e) => (ECAbs (x, k, exp (UnknownC :: env) e), loc)
adamc@509 222
adamc@509 223 | ERecord xcs => (ERecord (map (fn (x, e, t) => (con env x, exp env e, con env t)) xcs), loc)
adamc@509 224 | EField (e, c, {field, rest}) =>
adamc@509 225 let
adamc@509 226 val e = exp env e
adamc@509 227 val c = con env c
adamc@509 228
adamc@509 229 fun default () = (EField (e, c, {field = con env field, rest = con env rest}), loc)
adamc@509 230 in
adamc@509 231 case (#1 e, #1 c) of
adamc@509 232 (ERecord xcs, CName x) =>
adamc@509 233 (case List.find (fn ((CName x', _), _, _) => x' = x | _ => false) xcs of
adamc@509 234 NONE => default ()
adamc@509 235 | SOME (_, e, _) => e)
adamc@509 236 | _ => default ()
adamc@509 237 end
adamc@509 238
adamc@509 239 | EConcat (e1, c1, e2, c2) =>
adamc@509 240 let
adamc@509 241 val e1 = exp env e1
adamc@509 242 val e2 = exp env e2
adamc@509 243 in
adamc@509 244 case (#1 e1, #1 e2) of
adamc@509 245 (ERecord xes1, ERecord xes2) => (ERecord (xes1 @ xes2), loc)
adamc@509 246 | _ =>
adamc@509 247 let
adamc@509 248 val c1 = con env c1
adamc@509 249 val c2 = con env c2
adamc@509 250 in
adamc@509 251 case (#1 c1, #1 c2) of
adamc@509 252 (CRecord (k, xcs1), CRecord (_, xcs2)) =>
adamc@509 253 let
adamc@509 254 val (xes1, rest) = ListUtil.foldlMap (doPart e1) [] xcs1
adamc@509 255 val (xes2, _) = ListUtil.foldlMap (doPart e2) rest xcs2
adamc@509 256 in
adamc@510 257 exp (deKnown env) (ERecord (xes1 @ xes2), loc)
adamc@509 258 end
adamc@509 259 | _ => (EConcat (e1, c1, e2, c2), loc)
adamc@509 260 end
adamc@509 261 end
adamc@509 262
adamc@509 263 | ECut (e, c, {field, rest}) =>
adamc@509 264 let
adamc@509 265 val e = exp env e
adamc@509 266 val c = con env c
adamc@509 267
adamc@509 268 fun default () =
adamc@509 269 let
adamc@509 270 val rest = con env rest
adamc@509 271 in
adamc@509 272 case #1 rest of
adamc@509 273 CRecord (k, xcs) =>
adamc@509 274 let
adamc@509 275 val (xes, _) = ListUtil.foldlMap (doPart e) [] xcs
adamc@509 276 in
adamc@510 277 exp (deKnown env) (ERecord xes, loc)
adamc@509 278 end
adamc@509 279 | _ => (ECut (e, c, {field = con env field, rest = rest}), loc)
adamc@509 280 end
adamc@509 281 in
adamc@509 282 case (#1 e, #1 c) of
adamc@509 283 (ERecord xes, CName x) =>
adamc@509 284 if List.all (fn ((CName _, _), _, _) => true | _ => false) xes then
adamc@509 285 (ERecord (List.filter (fn ((CName x', _), _, _) => x' <> x
adamc@509 286 | _ => raise Fail "Reduce: ECut") xes), loc)
adamc@509 287 else
adamc@509 288 default ()
adamc@509 289 | _ => default ()
adamc@509 290 end
adamc@509 291
adamc@509 292 | ECutMulti (e, c, {rest}) =>
adamc@509 293 let
adamc@509 294 val e = exp env e
adamc@509 295 val c = con env c
adamc@509 296
adamc@509 297 fun default () =
adamc@509 298 let
adamc@509 299 val rest = con env rest
adamc@509 300 in
adamc@509 301 case #1 rest of
adamc@509 302 CRecord (k, xcs) =>
adamc@509 303 let
adamc@509 304 val (xes, _) = ListUtil.foldlMap (doPart e) [] xcs
adamc@509 305 in
adamc@510 306 exp (deKnown env) (ERecord xes, loc)
adamc@509 307 end
adamc@509 308 | _ => (ECutMulti (e, c, {rest = rest}), loc)
adamc@509 309 end
adamc@509 310 in
adamc@509 311 case (#1 e, #1 c) of
adamc@509 312 (ERecord xes, CRecord (_, xcs)) =>
adamc@509 313 if List.all (fn ((CName _, _), _, _) => true | _ => false) xes
adamc@509 314 andalso List.all (fn ((CName _, _), _) => true | _ => false) xcs then
adamc@509 315 (ERecord (List.filter (fn ((CName x', _), _, _) =>
adamc@509 316 List.all (fn ((CName x, _), _) => x' <> x
adamc@509 317 | _ => raise Fail "Reduce: ECutMulti [1]") xcs
adamc@509 318 | _ => raise Fail "Reduce: ECutMulti [2]") xes), loc)
adamc@509 319 else
adamc@509 320 default ()
adamc@509 321 | _ => default ()
adamc@509 322 end
adamc@509 323
adamc@509 324 | EFold _ => all
adamc@509 325
adamc@509 326 | ECase (e, pes, {disc, result}) =>
adamc@509 327 let
adamc@509 328 fun patBinds (p, _) =
adamc@509 329 case p of
adamc@509 330 PWild => 0
adamc@509 331 | PVar _ => 1
adamc@509 332 | PPrim _ => 0
adamc@509 333 | PCon (_, _, _, NONE) => 0
adamc@509 334 | PCon (_, _, _, SOME p) => patBinds p
adamc@509 335 | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts
adamc@509 336
adamc@509 337 fun pat (all as (p, loc)) =
adamc@509 338 case p of
adamc@509 339 PWild => all
adamc@509 340 | PVar (x, t) => (PVar (x, con env t), loc)
adamc@509 341 | PPrim _ => all
adamc@509 342 | PCon (dk, pc, cs, po) =>
adamc@509 343 (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc)
adamc@509 344 | PRecord xpts => (PRecord (map (fn (x, p, t) => (x, pat p, con env t)) xpts), loc)
adamc@509 345 in
adamc@509 346 (ECase (exp env e,
adamc@509 347 map (fn (p, e) => (pat p,
adamc@509 348 exp (List.tabulate (patBinds p, fn _ => UnknownE) @ env) e))
adamc@509 349 pes, {disc = con env disc, result = con env result}), loc)
adamc@509 350 end
adamc@509 351
adamc@509 352 | EWrite e => (EWrite (exp env e), loc)
adamc@509 353 | EClosure (n, es) => (EClosure (n, map (exp env) es), loc)
adamc@509 354
adamc@510 355 | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc))
adamc@417 356 in
adamc@508 357 {con = con, exp = exp}
adamc@417 358 end
adamc@21 359
adamc@509 360 fun con namedC env c = #con (conAndExp (namedC, IM.empty)) env c
adamc@509 361 fun exp (namedC, namedE) env e = #exp (conAndExp (namedC, namedE)) env e
adamc@20 362
adamc@508 363 fun reduce file =
adamc@508 364 let
adamc@508 365 fun doDecl (d as (_, loc), st as (namedC, namedE)) =
adamc@508 366 case #1 d of
adamc@508 367 DCon (x, n, k, c) =>
adamc@508 368 let
adamc@509 369 val c = con namedC [] c
adamc@508 370 in
adamc@508 371 ((DCon (x, n, k, c), loc),
adamc@508 372 (IM.insert (namedC, n, c), namedE))
adamc@508 373 end
adamc@508 374 | DDatatype (x, n, ps, cs) =>
adamc@509 375 let
adamc@509 376 val env = map (fn _ => UnknownC) ps
adamc@509 377 in
adamc@509 378 ((DDatatype (x, n, ps, map (fn (x, n, co) => (x, n, Option.map (con namedC env) co)) cs), loc),
adamc@509 379 st)
adamc@509 380 end
adamc@508 381 | DVal (x, n, t, e, s) =>
adamc@508 382 let
adamc@509 383 val t = con namedC [] t
adamc@509 384 val e = exp (namedC, namedE) [] e
adamc@508 385 in
adamc@508 386 ((DVal (x, n, t, e, s), loc),
adamc@508 387 (namedC, IM.insert (namedE, n, e)))
adamc@508 388 end
adamc@508 389 | DValRec vis =>
adamc@509 390 ((DValRec (map (fn (x, n, t, e, s) => (x, n, con namedC [] t, exp (namedC, namedE) [] e, s)) vis), loc),
adamc@508 391 st)
adamc@508 392 | DExport _ => (d, st)
adamc@509 393 | DTable (s, n, c, s') => ((DTable (s, n, con namedC [] c, s'), loc), st)
adamc@508 394 | DSequence _ => (d, st)
adamc@508 395 | DDatabase _ => (d, st)
adamc@509 396 | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st)
adamc@20 397
adamc@508 398 val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty) file
adamc@508 399 in
adamc@508 400 file
adamc@508 401 end
adamc@20 402
adamc@20 403 end