Mercurial > urweb
changeset 919:cc956020801b
'more' demos working after optimizer fix
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 08 Sep 2009 19:42:12 -0400 |
| parents | 6a77c3e33908 |
| children | 7accd4546cf9 |
| files | demo/more/out/dragList.css src/mono_reduce.sml src/mono_util.sig src/mono_util.sml |
| diffstat | 4 files changed, 56 insertions(+), 20 deletions(-) [+] |
line wrap: on
line diff
--- a/demo/more/out/dragList.css Tue Sep 08 11:02:53 2009 -0400 +++ b/demo/more/out/dragList.css Tue Sep 08 19:42:12 2009 -0400 @@ -7,7 +7,7 @@ color: #7E9E50; font: 20px Georgia; background-color: #ECF3E1; - border:1px solid #C5DEA1; + border: 1px solid #C5DEA1; cursor: move; margin: 0px; }
--- a/src/mono_reduce.sml Tue Sep 08 11:02:53 2009 -0400 +++ b/src/mono_reduce.sml Tue Sep 08 19:42:12 2009 -0400 @@ -38,19 +38,36 @@ structure IS = IntBinarySet +val simpleTypeImpure = + U.Typ.exists (fn TFun _ => true + | TDatatype _ => true + | _ => false) + fun simpleImpure syms = - U.Exp.exists {typ = fn _ => false, - exp = fn EWrite _ => true - | EQuery _ => true - | EDml _ => true - | ENextval _ => true - | EUnurlify _ => true - | EFfiApp (m, x, _) => Settings.isEffectful (m, x) - | EServerCall _ => true - | ERecv _ => true - | ESleep _ => true - | ENamed n => IS.member (syms, n) - | _ => false} + U.Exp.existsB {typ = fn _ => false, + exp = fn (env, e) => + case e of + EWrite _ => true + | EQuery _ => true + | EDml _ => true + | ENextval _ => true + | EUnurlify _ => true + | EFfiApp (m, x, _) => Settings.isEffectful (m, x) + | EServerCall _ => true + | ERecv _ => true + | ESleep _ => true + | ENamed n => IS.member (syms, n) + | ERel n => + let + val (_, t, _) = E.lookupERel env n + in + simpleTypeImpure t + end + | _ => false, + bind = fn (env, b) => + case b of + U.Exp.RelE (x, t) => E.pushERel env x t NONE + | _ => env} fun impure (e, _) = case e of @@ -268,13 +285,13 @@ in case d of DVal (_, n, _, e, _) => - (if simpleImpure impures e then + (if simpleImpure impures E.empty e then IS.add (impures, n) else impures, IM.insert (absCounts, n, countAbs e)) | DValRec vis => - (if List.exists (fn (_, _, _, e, _) => simpleImpure impures e) vis then + (if List.exists (fn (_, _, _, e, _) => simpleImpure impures E.empty e) vis then foldl (fn ((_, n, _, _, _), impures) => IS.add (impures, n)) impures vis else @@ -390,8 +407,8 @@ s end - val impure = fn e => - simpleImpure impures e andalso impure e + val impure = fn env => fn e => + simpleImpure impures env e andalso impure e andalso not (List.null (summarize ~1 e)) fun exp env e = @@ -415,7 +432,7 @@ ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1), ("e2", MonoPrint.p_exp env e2), ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*) - if impure e2 then + if impure env e2 then #1 (reduceExp env (ELet (x, t, e2, e1), loc)) else #1 (reduceExp env (subExpInExp (0, e2) e1))) @@ -490,7 +507,7 @@ (EApp (b, liftExpInExp 0 e'), loc)), loc)) | ELet (x, t, e', (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) => - if impure e' then + if impure env e' then e else EAbs (x', t', ran, reduceExp env (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc)) @@ -518,7 +535,7 @@ (ECase _, _) => e | _ => doSub ()) in - if impure e' then + if impure env e' then let val effs_e' = summarize 0 e' val effs_e' = List.filter (fn x => x <> UseRel) effs_e'
--- a/src/mono_util.sig Tue Sep 08 11:02:53 2009 -0400 +++ b/src/mono_util.sig Tue Sep 08 19:42:12 2009 -0400 @@ -72,6 +72,10 @@ val exists : {typ : Mono.typ' -> bool, exp : Mono.exp' -> bool} -> Mono.exp -> bool + val existsB : {typ : Mono.typ' -> bool, + exp : 'context * Mono.exp' -> bool, + bind : 'context * binder -> 'context} -> 'context -> Mono.exp -> bool + val foldB : {typ : Mono.typ' * 'state -> 'state, exp : 'context * Mono.exp' * 'state -> 'state, bind : 'context * binder -> 'context}
--- a/src/mono_util.sml Tue Sep 08 11:02:53 2009 -0400 +++ b/src/mono_util.sml Tue Sep 08 19:42:12 2009 -0400 @@ -434,6 +434,21 @@ S.Return _ => true | S.Continue _ => false +fun existsB {typ, exp, bind} ctx e = + case mapfoldB {typ = fn t => fn () => + if typ t then + S.Return () + else + S.Continue (t, ()), + exp = fn ctx => fn e => fn () => + if exp (ctx, e) then + S.Return () + else + S.Continue (e, ()), + bind = bind} ctx e () of + S.Return _ => true + | S.Continue _ => false + fun foldB {typ, exp, bind} ctx s e = case mapfoldB {typ = fn t => fn s => S.Continue (t, typ (t, s)), exp = fn ctx => fn e => fn s => S.Continue (e, exp (ctx, e, s)),