| 213 |
LT.tc_eqv(tyc1,tyc2) andalso tycs_eq(tycs1,tycs2) |
LT.tc_eqv(tyc1,tyc2) andalso tycs_eq(tycs1,tycs2) |
| 214 |
| tycs_eq _ = false |
| tycs_eq _ = false |
| 215 |
|
|
| 216 |
|
fun contract (fdec as (_,f,_,_)) = let |
| 217 |
|
|
| 218 |
|
val inlineWitness = ref false |
| 219 |
|
|
| 220 |
(* cfg: is used for deBruijn renumbering when inlining at different depths |
(* cfg: is used for deBruijn renumbering when inlining at different depths |
| 221 |
* ifs (inlined functions): records which functions we're currently inlining |
* ifs (inlined functions): records which functions we're currently inlining |
| 222 |
* in order to detect loops |
* in order to detect loops |
| 332 |
* and kill only the function name. This inlining strategy |
* and kill only the function name. This inlining strategy |
| 333 |
* looks inoffensive enough, but still requires some care: |
* looks inoffensive enough, but still requires some care: |
| 334 |
* see comments at the begining of this file and in cfun *) |
* see comments at the begining of this file and in cfun *) |
| 335 |
(C.unuse (fn _ => ()) true g; |
(inlineWitness := true; |
| 336 |
|
C.unuse (fn _ => ()) true g; |
| 337 |
ASSERT(not (used g), "killed"); |
ASSERT(not (used g), "killed"); |
| 338 |
(SOME(F.LET(map #1 args, F.RET vs, body), od), ifs)) |
(SOME(F.LET(map #1 args, F.RET vs, body), od), ifs)) |
| 339 |
|
|
| 349 |
let val nle = |
let val nle = |
| 350 |
C.copylexp M.empty (F.LET(map #1 args, F.RET vs, body)) |
C.copylexp M.empty (F.LET(map #1 args, F.RET vs, body)) |
| 351 |
in |
in |
| 352 |
|
inlineWitness := true; |
| 353 |
(* say ("\nInlining "^(C.LVarString g)); *) |
(* say ("\nInlining "^(C.LVarString g)); *) |
| 354 |
(app (unuseval (undertake m)) vs) handle x => raise x; |
(app (unuseval (undertake m)) vs) handle x => raise x; |
| 355 |
(C.unuse (undertake m) true g) handle x => raise x; |
(C.unuse (undertake m) true g) handle x => raise x; |
| 431 |
| cfun (m,fdec as ({inline,cconv,known,isrec},f,args,body)::fs,acc) = |
| cfun (m,fdec as ({inline,cconv,known,isrec},f,args,body)::fs,acc) = |
| 432 |
if used f then |
if used f then |
| 433 |
let (* val _ = say ("\nEntering "^(C.LVarString f)) *) |
let (* val _ = say ("\nEntering "^(C.LVarString f)) *) |
| 434 |
|
val oldWitness = |
| 435 |
|
(!inlineWitness before inlineWitness := false) |
| 436 |
(* make up the bindings for args inside the body *) |
(* make up the bindings for args inside the body *) |
| 437 |
fun addnobind ((lv,lty),m) = |
fun addnobind ((lv,lty),m) = |
| 438 |
addbind(m, lv, Var(lv, SOME lty)) |
addbind(m, lv, Var(lv, SOME lty)) |
| 439 |
val nm = foldl addnobind m args |
val nm = foldl addnobind m args |
| 440 |
(* contract the body and create the resulting fundec *) |
(* contract the body and create the resulting fundec *) |
| 441 |
val nbody = cexp cfg (S.add(f, ifs)) nm body #2 |
val nbody = cexp cfg (S.add(f, ifs)) nm body #2 |
| 442 |
(* The `inline' bit has to be turned off because |
(* if inlining took place, the body might be completely |
| 443 |
* it applied to the function before contraction |
* changed (read: bigger), so we have to reset the |
| 444 |
* but might not apply to its new form (inlining might |
* `inline' bit *) |
|
* have increased its size substantially or made it |
|
|
* recursive in a different way which could make further |
|
|
* inlining even dangerous) *) |
|
|
val nknown = known orelse not(C.escaping f) |
|
| 445 |
val nfk = {isrec=isrec, cconv=cconv, |
val nfk = {isrec=isrec, cconv=cconv, |
| 446 |
inline=F.IH_SAFE, known=nknown} |
known=known orelse not(C.escaping f), |
| 447 |
|
inline=if !inlineWitness |
| 448 |
|
then F.IH_SAFE |
| 449 |
|
else (inline before |
| 450 |
|
inlineWitness := oldWitness)} |
| 451 |
(* update the binding in the map. This step is not |
(* update the binding in the map. This step is not |
| 452 |
* not just a mere optimization but is necessary |
* not just a mere optimization but is necessary |
| 453 |
* because if we don't do it and the function |
* because if we don't do it and the function |
| 475 |
* escaping one. It's dangerous for optimisations based |
* escaping one. It's dangerous for optimisations based |
| 476 |
* on known functions (elimination of dead args, f.ex) |
* on known functions (elimination of dead args, f.ex) |
| 477 |
* and could generate cases where call>use in collect *) |
* and could generate cases where call>use in collect *) |
| 478 |
in if not (C.escaping f andalso |
in if not (C.escaping f andalso not (C.escaping g)) |
|
not (C.escaping g)) |
|
| 479 |
then let |
then let |
| 480 |
(* if an earlier function h has been eta-reduced |
(* if an earlier function h has been eta-reduced |
| 481 |
* to f, we have to be careful to update its |
* to f, we have to be careful to update its |
| 525 |
(* construct the new body *) |
(* construct the new body *) |
| 526 |
val nbody = |
val nbody = |
| 527 |
F.LET(map #1 (filter args), |
F.LET(map #1 (filter args), |
| 528 |
F.RET(map valOf (filter (C.actuals g))), |
F.RET(map O.valOf (filter (C.actuals g))), |
| 529 |
body) |
body) |
| 530 |
in (fk, g, nargs, nbody) |
in (fk, g, nargs, nbody) |
| 531 |
end |
end |
| 620 |
|
|
| 621 |
| F.SWITCH (v,ac,arms,def) => |
| F.SWITCH (v,ac,arms,def) => |
| 622 |
(case ((val2sval m v) handle x => raise x) |
(case ((val2sval m v) handle x => raise x) |
| 623 |
of sv as (Var{1=lvc,...} | Select{1=lvc,...} | Decon{1=lvc, ...} |
of sv as Con (lvc,v,dc1,tycs1) => |
|
| (* will probably never happen *) Record{1=lvc,...}) => |
|
|
let fun carm (F.DATAcon(dc,tycs,lv),le) = |
|
|
let val ndc = cdcon dc |
|
|
val nm = addbind(m, lv, Decon(lv, F.VAR lvc, ndc, tycs)) |
|
|
(* we can rebind lv to a more precise value |
|
|
* !!BEWARE!! This rebinding is misleading: |
|
|
* - it gives the impression that `lvc' is built from |
|
|
* `lv' although the reverse is true: if `lvc' is |
|
|
* undertaken, `lv's count should *not* be updated! |
|
|
* Luckily, `lvc' will not become dead while rebound |
|
|
* to Con(lv) because it's used by the SWITCH. |
|
|
* All in all, it works fine, but it's not as |
|
|
* straightforward as it seems. |
|
|
* - it seems to be a good idea, but it can hide |
|
|
* other opt-opportunities since it hides the |
|
|
* previous binding. *) |
|
|
val nm = addbind(nm, lvc, Con(lvc, F.VAR lv, ndc, tycs)) |
|
|
in (F.DATAcon(ndc, tycs, lv), loop nm le #2) |
|
|
end |
|
|
| carm (con,le) = (con, loop m le #2) |
|
|
val narms = map carm arms |
|
|
val ndef = Option.map (fn le => loop m le #2) def |
|
|
in |
|
|
cont(m, F.SWITCH(sval2val sv, ac, narms, ndef)) |
|
|
end |
|
|
|
|
|
| Con (lvc,v,dc1,tycs1) => |
|
| 624 |
let fun killle le = ((#1 (C.unuselexp (undertake m))) le) handle x => raise x |
let fun killle le = ((#1 (C.unuselexp (undertake m))) le) handle x => raise x |
| 625 |
fun kill lv le = |
fun kill lv le = |
| 626 |
((#1 (C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))))) le) handle x => raise x |
((#1 (C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))))) le) handle x => raise x |
| 628 |
| killarm _ = buglexp("bad arm in switch(con)", le) |
| killarm _ = buglexp("bad arm in switch(con)", le) |
| 629 |
|
|
| 630 |
fun carm ((F.DATAcon(dc2,tycs2,lv),le)::tl) = |
fun carm ((F.DATAcon(dc2,tycs2,lv),le)::tl) = |
| 631 |
if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then |
(* sometimes lty1 <> lty2 :-( so this doesn't work: |
| 632 |
|
* FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) *) |
| 633 |
|
if #2 dc1 = #2 (cdcon dc2) then |
| 634 |
(map killarm tl; (* kill the rest *) |
(map killarm tl; (* kill the rest *) |
| 635 |
Option.map killle def; (* and the default case *) |
O.map killle def; (* and the default case *) |
| 636 |
loop (substitute(m, lv, val2sval m v, F.VAR lvc)) |
loop (substitute(m, lv, val2sval m v, F.VAR lvc)) |
| 637 |
le cont) |
le cont) |
| 638 |
else |
else |
| 639 |
(* kill this arm and continue with the rest *) |
(* kill this arm and continue with the rest *) |
| 640 |
(kill lv le; carm tl) |
(kill lv le; carm tl) |
| 641 |
| carm [] = loop m (Option.valOf def) cont |
| carm [] = loop m (O.valOf def) cont |
| 642 |
| carm _ = buglexp("unexpected arm in switch(con,...)", le) |
| carm _ = buglexp("unexpected arm in switch(con,...)", le) |
| 643 |
in carm arms |
in carm arms |
| 644 |
end |
end |
| 645 |
|
|
| 646 |
| Val v => |
| sv as Val v => |
| 647 |
let fun kill le = ((#1 (C.unuselexp (undertake m))) le) handle x => raise x |
let fun kill le = ((#1 (C.unuselexp (undertake m))) le) handle x => raise x |
| 648 |
fun carm ((con,le)::tl) = |
fun carm ((con,le)::tl) = |
| 649 |
if eqConV(con, v) then |
if eqConV(con, v) then |
| 650 |
(map (kill o #2) tl; |
(map (kill o #2) tl; |
| 651 |
Option.map kill def; |
O.map kill def; |
| 652 |
loop m le cont) |
loop m le cont) |
| 653 |
else (kill le; carm tl) |
else (kill le; carm tl) |
| 654 |
| carm [] = loop m (Option.valOf def) cont |
| carm [] = loop m (O.valOf def) cont |
| 655 |
in carm arms |
in carm arms |
| 656 |
end |
end |
| 657 |
|
|
| 658 |
|
| sv as (Var{1=lvc,...} | Select{1=lvc,...} | Decon{1=lvc, ...} |
| 659 |
|
| (* will probably never happen *) Record{1=lvc,...}) => |
| 660 |
|
(case (arms,def) |
| 661 |
|
of ([(F.DATAcon(dc,tycs,lv),le)],NONE) => |
| 662 |
|
(* this is a mere DECON, so we can push the let binding |
| 663 |
|
* (hidden in cont) inside and maybe even drop the DECON *) |
| 664 |
|
let val ndc = cdcon dc |
| 665 |
|
val nm = addbind(m, lv, Decon(lv, F.VAR lvc, ndc, tycs)) |
| 666 |
|
(* see below *) |
| 667 |
|
val nm = addbind(nm, lvc, Con(lvc, F.VAR lv, ndc, tycs)) |
| 668 |
|
val nle = loop nm le cont |
| 669 |
|
val nv = sval2val sv |
| 670 |
|
in |
| 671 |
|
if used lv then |
| 672 |
|
F.SWITCH(nv,ac,[(F.DATAcon(ndc,tycs,lv),nle)],NONE) |
| 673 |
|
else (unuseval (undertake m) nv; nle) |
| 674 |
|
end |
| 675 |
|
| (([(_,le)],NONE) | ([],SOME le)) => |
| 676 |
|
(* This should never happen, but we can optimize it away *) |
| 677 |
|
(unuseval (undertake m) (sval2val sv); loop m le cont) |
| 678 |
|
| _ => |
| 679 |
|
let fun carm (F.DATAcon(dc,tycs,lv),le) = |
| 680 |
|
let val ndc = cdcon dc |
| 681 |
|
val nm = addbind(m, lv, |
| 682 |
|
Decon(lv, F.VAR lvc, ndc, tycs)) |
| 683 |
|
(* we can rebind lv to a more precise value |
| 684 |
|
* !!BEWARE!! This rebinding is misleading: |
| 685 |
|
* - it gives the impression that `lvc' is built |
| 686 |
|
* from`lv' although the reverse is true: |
| 687 |
|
* if `lvc' is undertaken, `lv's count should |
| 688 |
|
* *not* be updated! |
| 689 |
|
* Luckily, `lvc' will not become dead while |
| 690 |
|
* rebound to Con(lv) because it's used by the |
| 691 |
|
* SWITCH. All in all, it works fine, but it's |
| 692 |
|
* not as straightforward as it seems. |
| 693 |
|
* - it seems to be a good idea, but it can hide |
| 694 |
|
* other opt-opportunities since it hides the |
| 695 |
|
* previous binding. *) |
| 696 |
|
val nm = addbind(nm, lvc, |
| 697 |
|
Con(lvc, F.VAR lv, ndc, tycs)) |
| 698 |
|
in (F.DATAcon(ndc, tycs, lv), loop nm le #2) |
| 699 |
|
end |
| 700 |
|
| carm (con,le) = (con, loop m le #2) |
| 701 |
|
val narms = map carm arms |
| 702 |
|
val ndef = Option.map (fn le => loop m le #2) def |
| 703 |
|
in cont(m, F.SWITCH(sval2val sv, ac, narms, ndef)) |
| 704 |
|
end) |
| 705 |
|
|
| 706 |
| sv as (Fun _ | TFun _) => |
| sv as (Fun _ | TFun _) => |
| 707 |
bugval("unexpected switch arg", sval2val sv)) |
bugval("unexpected switch arg", sval2val sv)) |
| 708 |
|
|
| 800 |
end |
end |
| 801 |
end |
end |
| 802 |
|
|
| 803 |
fun contract (fdec as (_,f,_,_)) = |
in |
| 804 |
((* C.collect fdec; *) |
(* C.collect fdec; *) |
| 805 |
case cexp (DI.top,DI.top) S.empty |
case cexp (DI.top,DI.top) S.empty |
| 806 |
M.empty (F.FIX([fdec], F.RET[F.VAR f])) #2 |
M.empty (F.FIX([fdec], F.RET[F.VAR f])) #2 |
| 807 |
of F.FIX([fdec], F.RET[F.VAR f]) => fdec |
of F.FIX([fdec], F.RET[F.VAR f]) => fdec |
| 808 |
| fdec => bug "invalid return fundec") |
| fdec => bug "invalid return fundec" |
| 809 |
|
end |
| 810 |
|
|
| 811 |
end |
end |
| 812 |
end |
end |
Parent Directory
| 
Revision Log
| 
Patch
