Mercurial > urweb

comparison src/reduce.sml @ 1805:d12192c7aa3e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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