summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-09-08 19:42:12 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-09-08 19:42:12 -0400
commitea0ad8d321ff7dbd659a5b5bfab8e4b81e8b8d47 (patch)
tree300ddd5b559729aafff0412876a6d507fcfafc28
parent5e954e635e58d3a7b34d6dc60d7c4aabd1c752f4 (diff)
'more' demos working after optimizer fix
-rw-r--r--demo/more/out/dragList.css2
-rw-r--r--src/mono_reduce.sml55
-rw-r--r--src/mono_util.sig4
-rw-r--r--src/mono_util.sml15
4 files changed, 56 insertions, 20 deletions
diff --git a/demo/more/out/dragList.css b/demo/more/out/dragList.css
index 8fd239a9..bcd892d5 100644
--- a/demo/more/out/dragList.css
+++ b/demo/more/out/dragList.css
@@ -7,7 +7,7 @@ li {
color: #7E9E50;
font: 20px Georgia;
background-color: #ECF3E1;
- border:1px solid #C5DEA1;
+ border: 1px solid #C5DEA1;
cursor: move;
margin: 0px;
}
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 0820d200..81351e55 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -38,19 +38,36 @@ structure IM = IntBinaryMap
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 @@ fun reduce file =
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 @@ fun reduce file =
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 @@ fun reduce file =
((*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 @@ fun reduce file =
(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 @@ fun reduce file =
(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'
diff --git a/src/mono_util.sig b/src/mono_util.sig
index 2a96211a..06290e7d 100644
--- a/src/mono_util.sig
+++ b/src/mono_util.sig
@@ -72,6 +72,10 @@ structure Exp : sig
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}
diff --git a/src/mono_util.sml b/src/mono_util.sml
index e2bed8eb..c660a4a3 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -434,6 +434,21 @@ fun exists {typ, exp} k =
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)),