Mercurial > urweb
comparison src/mono_reduce.sml @ 1017:34ba25d6af3b
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) |