Mercurial > urweb

comparison src/reduce.sml @ 1804:62c18ecbfec4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Tweaking treatment of function application: substitute or introduce a 'let'?
author Adam Chlipala <adam@chlipala.net>
date Sun, 05 Aug 2012 14:55:28 -0400
parents 0577be31a435
children d12192c7aa3e
comparison
equal deleted inserted replaced
1803:d2383ffc18ab 1804:62c18ecbfec4
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
234 249
235 fun kindConAndExp (namedC, namedE) = 250 fun kindConAndExp (namedC, namedE) =
236 let 251 let
237 fun kind env (all as (k, loc)) = 252 fun kind env (all as (k, loc)) =
238 case k of 253 case k of
532 547
533 val e1 = exp env e1 548 val e1 = exp env e1
534 val e2 = exp env e2 549 val e2 = exp env e2
535 in 550 in
536 case #1 e1 of 551 case #1 e1 of
537 EAbs (_, _, _, b) => 552 ELet (x, t, e1', e2') =>
538 let 553 (ELet (x, t, e1', exp (UnknownE :: env') (EApp (e2', E.liftExpInExp 0 e2), loc)), loc)
539 val r = exp (KnownE e2 :: env') b 554
540 in 555 | EAbs (x, dom, _, b) =>
541 (*Print.prefaces "eapp" [("b", CorePrint.p_exp CoreEnv.empty b), 556 if count b <= 1 orelse passive e2 orelse ESpecialize.functionInside dom then
542 ("env", Print.PD.string (e2s env')), 557 let
543 ("e2", CorePrint.p_exp CoreEnv.empty e2), 558 val r = exp (KnownE e2 :: env') b
544 ("r", CorePrint.p_exp CoreEnv.empty r)];*) 559 in
545 r 560 (*Print.prefaces "eapp" [("b", CorePrint.p_exp CoreEnv.empty b),
546 end 561 ("env", Print.PD.string (e2s env')),
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
547 | ECase (e, pes, cc as {disc, result = res as (TFun (_, c2), _)}) => 576 | ECase (e, pes, cc as {disc, result = res as (TFun (_, c2), _)}) =>
548 let 577 let
549 val pes' = map (fn (p, body) => 578 val pes' = map (fn (p, body) =>
550 let 579 let
551 val env' = List.tabulate (patBinds p, fn _ => UnknownE) @ deKnown env 580 val env' = List.tabulate (patBinds p, fn _ => UnknownE) @ deKnown env
758 | EWrite e => (EWrite (exp env e), loc) 787 | EWrite e => (EWrite (exp env e), loc)
759 | EClosure (n, es) => (EClosure (n, map (exp env) es), loc) 788 | EClosure (n, es) => (EClosure (n, map (exp env) es), loc)
760 789
761 | ELet (x, t, e1, e2) => 790 | ELet (x, t, e1, e2) =>
762 let 791 let
792 val e1' = exp env e1
793
763 val t = con env t 794 val t = con env t
764 in 795 in
765 if ESpecialize.functionInside t then 796 if passive e1' orelse count e2 <= 1 orelse ESpecialize.functionInside t then
766 exp (KnownE e1 :: env) e2 797 exp (KnownE e1 :: env) e2
767 else 798 else
768 (ELet (x, t, exp env e1, exp (UnknownE :: env) e2), loc) 799 (ELet (x, t, e1', exp (UnknownE :: env) e2), loc)
769 end 800 end
770 801
771 | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, con env t), loc) 802 | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, con env t), loc)
772 in 803 in
773 (*if dangling (edepth' (deKnown env)) r then 804 (*if dangling (edepth' (deKnown env)) r then