Mercurial > urweb

comparison src/mono_reduce.sml @ 1017:34ba25d6af3b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Inlining threshold for Mono_reduce
author Adam Chlipala <adamc@hcoop.net>
date Sun, 25 Oct 2009 12:48:50 -0400
parents 166ea3944b91
children dfe34fad749d
comparison
equal deleted inserted replaced
1016:065ce3252090 1017:34ba25d6af3b
334 IM.insert (absCounts, n, countAbs e)) 334 IM.insert (absCounts, n, countAbs e))
335 absCounts vis) 335 absCounts vis)
336 | _ => (timpures, impures, absCounts) 336 | _ => (timpures, impures, absCounts)
337 end) 337 end)
338 (IS.empty, IS.empty, IM.empty) file 338 (IS.empty, IS.empty, IM.empty) file
339
340 val uses = U.File.fold {typ = fn (_, m) => m,
341 exp = fn (e, m) =>
342 case e of
343 ENamed n => IM.insert (m, n, 1 + Option.getOpt (IM.find (m, n), 0))
344 | _ => m,
345 decl = fn (_, m) => m}
346 IM.empty file
347
348 val size = U.Exp.fold {typ = fn (_, n) => n,
349 exp = fn (_, n) => n + 1} 0
350
351 fun mayInline (n, e) =
352 case IM.find (uses, n) of
353 NONE => false
354 | SOME count => count <= 1
355 orelse size e <= Settings.getMonoInline ()
339 356
340 fun summarize d (e, _) = 357 fun summarize d (e, _) =
341 let 358 let
342 val s = 359 val s =
343 case e of 360 case e of
450 467
451 fun exp env e = 468 fun exp env e =
452 let 469 let
453 (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*) 470 (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*)
454 471
472 fun doLet (x, t, e', b) =
473 let
474 fun doSub () =
475 let
476 val r = subExpInExp (0, e') b
477 in
478 (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'),
479 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
480 ("r", MonoPrint.p_exp env r)];*)
481 #1 (reduceExp env r)
482 end
483
484 fun trySub () =
485 ((*Print.prefaces "trySub"
486 [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))];*)
487 case t of
488 (TFfi ("Basis", "string"), _) => doSub ()
489 | (TSignal _, _) => e
490 | _ =>
491 case e' of
492 (ECase _, _) => e
493 | _ => doSub ())
494 in
495 if impure env e' then
496 let
497 val effs_e' = summarize 0 e'
498 val effs_e' = List.filter (fn x => x <> UseRel) effs_e'
499 val effs_b = summarize 0 b
500
501 (*val () = Print.prefaces "Try"
502 [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),
503 ("e'", MonoPrint.p_exp env e'),
504 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
505 ("e'_eff", p_events effs_e'),
506 ("b_eff", p_events effs_b)]*)
507
508 fun does eff = List.exists (fn eff' => eff' = eff) effs_e'
509 val writesPage = does WritePage
510 val readsDb = does ReadDb
511 val writesDb = does WriteDb
512
513 fun verifyUnused eff =
514 case eff of
515 UseRel => false
516 | _ => true
517
518 fun verifyCompatible effs =
519 case effs of
520 [] => false
521 | eff :: effs =>
522 case eff of
523 Unsure => false
524 | UseRel => List.all verifyUnused effs
525 | WritePage => not writesPage andalso verifyCompatible effs
526 | ReadDb => not writesDb andalso verifyCompatible effs
527 | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs
528 in
529 (*Print.prefaces "verifyCompatible"
530 [("e'", MonoPrint.p_exp env e'),
531 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
532 ("effs_e'", Print.p_list p_event effs_e'),
533 ("effs_b", Print.p_list p_event effs_b)];*)
534 if (List.null effs_e'
535 orelse (List.all (fn eff => eff <> Unsure) effs_e'
536 andalso verifyCompatible effs_b)
537 orelse (case effs_b of
538 UseRel :: effs => List.all verifyUnused effs
539 | _ => false))
540 andalso countFree 0 0 b = 1
541 andalso not (freeInAbs b) then
542 trySub ()
543 else
544 e
545 end
546 else
547 trySub ()
548 end
549
455 val r = 550 val r =
456 case e of 551 case e of
457 ERel n => 552 ERel n =>
458 (case E.lookupERel env n of 553 (case E.lookupERel env n of
459 (_, _, SOME e') => #1 e' 554 (_, _, SOME e') => #1 e'
544 end 639 end
545 | EApp ((ELet (x, t, e, b), loc), e') => 640 | EApp ((ELet (x, t, e, b), loc), e') =>
546 #1 (reduceExp env (ELet (x, t, e, 641 #1 (reduceExp env (ELet (x, t, e,
547 (EApp (b, liftExpInExp 0 e'), loc)), loc)) 642 (EApp (b, liftExpInExp 0 e'), loc)), loc))
548 643
549 | ELet (x, t, e', (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) => 644 | ELet (x, t, e', b as (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) =>
550 if impure env e' then 645 if impure env e' then
551 e 646 doLet (x, t, e', b)
552 else 647 else
553 EAbs (x', t', ran, reduceExp (E.pushERel env x' t' NONE) 648 EAbs (x', t', ran, reduceExp (E.pushERel env x' t' NONE)
554 (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc)) 649 (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc))
555 650
556 | ELet (x, t, e', b) => 651 | ELet (x, t, e', b) => doLet (x, t, e', b)
557 let
558 fun doSub () =
559 let
560 val r = subExpInExp (0, e') b
561 in
562 (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'),
563 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
564 ("r", MonoPrint.p_exp env r)];*)
565 #1 (reduceExp env r)
566 end
567
568 fun trySub () =
569 ((*Print.prefaces "trySub"
570 [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))];*)
571 case t of
572 (TFfi ("Basis", "string"), _) => doSub ()
573 | (TSignal _, _) => e
574 | _ =>
575 case e' of
576 (ECase _, _) => e
577 | _ => doSub ())
578 in
579 if impure env e' then
580 let
581 val effs_e' = summarize 0 e'
582 val effs_e' = List.filter (fn x => x <> UseRel) effs_e'
583 val effs_b = summarize 0 b
584
585 (*val () = Print.prefaces "Try"
586 [(*("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),*)
587 ("e'", MonoPrint.p_exp env e'),
588 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
589 ("e'_eff", p_events effs_e'),
590 ("b", p_events effs_b)]*)
591
592 fun does eff = List.exists (fn eff' => eff' = eff) effs_e'
593 val writesPage = does WritePage
594 val readsDb = does ReadDb
595 val writesDb = does WriteDb
596
597 fun verifyUnused eff =
598 case eff of
599 UseRel => false
600 | _ => true
601
602 fun verifyCompatible effs =
603 case effs of
604 [] => false
605 | eff :: effs =>
606 case eff of
607 Unsure => false
608 | UseRel => List.all verifyUnused effs
609 | WritePage => not writesPage andalso verifyCompatible effs
610 | ReadDb => not writesDb andalso verifyCompatible effs
611 | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs
612 in
613 (*Print.prefaces "verifyCompatible"
614 [("e'", MonoPrint.p_exp env e'),
615 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
616 ("effs_e'", Print.p_list p_event effs_e'),
617 ("effs_b", Print.p_list p_event effs_b)];*)
618 if (List.null effs_e'
619 orelse (List.all (fn eff => eff <> Unsure) effs_e'
620 andalso verifyCompatible effs_b)
621 orelse (case effs_b of
622 UseRel :: effs => List.all verifyUnused effs
623 | _ => false))
624 andalso countFree 0 0 b = 1
625 andalso not (freeInAbs b) then
626 trySub ()
627 else
628 e
629 end
630 else
631 trySub ()
632 end
633 652
634 | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) => 653 | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) =>
635 EPrim (Prim.String (s1 ^ s2)) 654 EPrim (Prim.String (s1 ^ s2))
636 655
637 | ESignalBind ((ESignalReturn e1, loc), e2) => 656 | ESignalBind ((ESignalReturn e1, loc), e2) =>
646 665
647 and bind (env, b) = 666 and bind (env, b) =
648 case b of 667 case b of
649 U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs 668 U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs
650 | U.Decl.RelE (x, t) => E.pushERel env x t NONE 669 | U.Decl.RelE (x, t) => E.pushERel env x t NONE
651 | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t (Option.map (reduceExp env) eo) s 670 | U.Decl.NamedE (x, n, t, eo, s) =>
671 let
672 val eo = case eo of
673 NONE => NONE
674 | SOME e => if mayInline (n, e) then
675 SOME e
676 else
677 NONE
678 in
679 E.pushENamed env x n t (Option.map (reduceExp env) eo) s
680 end
652 681
653 and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env 682 and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env
654 683
655 fun decl env d = ((*Print.preface ("d", MonoPrint.p_decl env (d, ErrorMsg.dummySpan));*) 684 fun decl env d = ((*Print.preface ("d", MonoPrint.p_decl env (d, ErrorMsg.dummySpan));*)
656 d) 685 d)