Mercurial > urweb
comparison src/reduce.sml @ 1805:d12192c7aa3e
Revert last changeset for now; needs more thought
author | Adam Chlipala <adam@chlipala.net> |
---|---|
date | Sun, 05 Aug 2012 17:11:39 -0400 |
parents | 62c18ecbfec4 |
children | 148203744882 |
comparison
equal
deleted
inserted
replaced
1804:62c18ecbfec4 | 1805:d12192c7aa3e |
---|---|
229 (TRecord (CRecord ((KType, loc), | 229 (TRecord (CRecord ((KType, loc), |
230 [((CName "Return", loc), | 230 [((CName "Return", loc), |
231 returnType m loc), | 231 returnType m loc), |
232 ((CName "Bind", loc), | 232 ((CName "Bind", loc), |
233 bindType m loc)]), loc), loc) | 233 bindType m loc)]), loc), loc) |
234 | |
235 fun passive (e : exp) = | |
236 case #1 e of | |
237 EPrim _ => true | |
238 | ERel _ => true | |
239 | ENamed _ => true | |
240 | ECon (_, _, _, NONE) => true | |
241 | ECon (_, _, _, SOME e) => passive e | |
242 | EFfi _ => true | |
243 | EAbs _ => true | |
244 | ECAbs _ => true | |
245 | EKAbs _ => true | |
246 | ERecord xes => List.all (passive o #2) xes | |
247 | EField (e, _, _) => passive e | |
248 | _ => false | |
249 | 234 |
250 fun kindConAndExp (namedC, namedE) = | 235 fun kindConAndExp (namedC, namedE) = |
251 let | 236 let |
252 fun kind env (all as (k, loc)) = | 237 fun kind env (all as (k, loc)) = |
253 case k of | 238 case k of |
547 | 532 |
548 val e1 = exp env e1 | 533 val e1 = exp env e1 |
549 val e2 = exp env e2 | 534 val e2 = exp env e2 |
550 in | 535 in |
551 case #1 e1 of | 536 case #1 e1 of |
552 ELet (x, t, e1', e2') => | 537 EAbs (_, _, _, b) => |
553 (ELet (x, t, e1', exp (UnknownE :: env') (EApp (e2', E.liftExpInExp 0 e2), loc)), loc) | 538 let |
554 | 539 val r = exp (KnownE e2 :: env') b |
555 | EAbs (x, dom, _, b) => | 540 in |
556 if count b <= 1 orelse passive e2 orelse ESpecialize.functionInside dom then | 541 (*Print.prefaces "eapp" [("b", CorePrint.p_exp CoreEnv.empty b), |
557 let | 542 ("env", Print.PD.string (e2s env')), |
558 val r = exp (KnownE e2 :: env') b | 543 ("e2", CorePrint.p_exp CoreEnv.empty e2), |
559 in | 544 ("r", CorePrint.p_exp CoreEnv.empty r)];*) |
560 (*Print.prefaces "eapp" [("b", CorePrint.p_exp CoreEnv.empty b), | 545 r |
561 ("env", Print.PD.string (e2s env')), | 546 end |
562 ("e2", CorePrint.p_exp CoreEnv.empty e2), | |
563 ("r", CorePrint.p_exp CoreEnv.empty r)];*) | |
564 r | |
565 end | |
566 else | |
567 let | |
568 val dom = con env' dom | |
569 val r = exp (UnknownE :: env') b | |
570 in | |
571 (*Print.prefaces "El skippo" [("x", Print.PD.string x), | |
572 ("e2", CorePrint.p_exp CoreEnv.empty e2)];*) | |
573 (ELet (x, dom, e2, r), loc) | |
574 end | |
575 | |
576 | ECase (e, pes, cc as {disc, result = res as (TFun (_, c2), _)}) => | 547 | ECase (e, pes, cc as {disc, result = res as (TFun (_, c2), _)}) => |
577 let | 548 let |
578 val pes' = map (fn (p, body) => | 549 val pes' = map (fn (p, body) => |
579 let | 550 let |
580 val env' = List.tabulate (patBinds p, fn _ => UnknownE) @ deKnown env | 551 val env' = List.tabulate (patBinds p, fn _ => UnknownE) @ deKnown env |
787 | EWrite e => (EWrite (exp env e), loc) | 758 | EWrite e => (EWrite (exp env e), loc) |
788 | EClosure (n, es) => (EClosure (n, map (exp env) es), loc) | 759 | EClosure (n, es) => (EClosure (n, map (exp env) es), loc) |
789 | 760 |
790 | ELet (x, t, e1, e2) => | 761 | ELet (x, t, e1, e2) => |
791 let | 762 let |
792 val e1' = exp env e1 | |
793 | |
794 val t = con env t | 763 val t = con env t |
795 in | 764 in |
796 if passive e1' orelse count e2 <= 1 orelse ESpecialize.functionInside t then | 765 if ESpecialize.functionInside t then |
797 exp (KnownE e1 :: env) e2 | 766 exp (KnownE e1 :: env) e2 |
798 else | 767 else |
799 (ELet (x, t, e1', exp (UnknownE :: env) e2), loc) | 768 (ELet (x, t, exp env e1, exp (UnknownE :: env) e2), loc) |
800 end | 769 end |
801 | 770 |
802 | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, con env t), loc) | 771 | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, con env t), loc) |
803 in | 772 in |
804 (*if dangling (edepth' (deKnown env)) r then | 773 (*if dangling (edepth' (deKnown env)) r then |