Mercurial > urweb

comparison src/mono_reduce.sml @ 932:0a156bbd205f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Full Grid1 compiles, thanks to avoiding code size blow-up in mono_reduce
author Adam Chlipala <adamc@hcoop.net>
date Sun, 13 Sep 2009 13:25:09 -0400
parents ae0110465421
children b8d7a47b8e0c
comparison
equal deleted inserted replaced
931:be6585b4058b 932:0a156bbd205f
272 | PCon (_, _, NONE) => 0 272 | PCon (_, _, NONE) => 0
273 | PCon (_, _, SOME p) => patBinds p 273 | PCon (_, _, SOME p) => patBinds p
274 | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts 274 | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts
275 | PNone _ => 0 275 | PNone _ => 0
276 | PSome (_, p) => patBinds p 276 | PSome (_, p) => patBinds p
277
278 val countFree = U.Exp.foldB {typ = fn (_, n) => n,
279 exp = fn (x, e, n) =>
280 case e of
281 ERel x' => if x = x' then n + 1 else n
282 | _ => n,
283 bind = fn (n, b) =>
284 case b of
285 U.Exp.RelE _ => n + 1
286 | _ => n} 0 0
277 287
278 fun reduce file = 288 fun reduce file =
279 let 289 let
280 val (impures, absCounts) = 290 val (impures, absCounts) =
281 foldl (fn ((d, _), (impures, absCounts)) => 291 foldl (fn ((d, _), (impures, absCounts)) =>
432 442
433 | EApp ((EAbs (x, t, _, e1), loc), e2) => 443 | EApp ((EAbs (x, t, _, e1), loc), e2) =>
434 ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1), 444 ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1),
435 ("e2", MonoPrint.p_exp env e2), 445 ("e2", MonoPrint.p_exp env e2),
436 ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*) 446 ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*)
437 if impure env e2 then 447 if impure env e2 orelse countFree e1 > 1 then
438 #1 (reduceExp env (ELet (x, t, e2, e1), loc)) 448 #1 (reduceExp env (ELet (x, t, e2, e1), loc))
439 else 449 else
440 #1 (reduceExp env (subExpInExp (0, e2) e1))) 450 #1 (reduceExp env (subExpInExp (0, e2) e1)))
441 451
442 | ECase (e', pes, {disc, result}) => 452 | ECase (e', pes, {disc, result}) =>
520 fun doSub () = 530 fun doSub () =
521 let 531 let
522 val r = subExpInExp (0, e') b 532 val r = subExpInExp (0, e') b
523 in 533 in
524 (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'), 534 (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'),
525 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), 535 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
526 ("r", MonoPrint.p_exp env r)];*) 536 ("r", MonoPrint.p_exp env r)];*)
527 #1 (reduceExp env r) 537 #1 (reduceExp env r)
528 end 538 end
529 539
530 fun trySub () = 540 fun trySub () =
531 ((*Print.prefaces "trySub" 541 ((*Print.prefaces "trySub"