# HG changeset patch
# User Adam Chlipala <adamc@hcoop.net>
# Date 1252453332 14400
# Node ID cc956020801b62029acd9da3f5132721526ac398
# Parent  6a77c3e3390824e426f3de1149e58f43277167a6
'more' demos working after optimizer fix

diff -r 6a77c3e33908 -r cc956020801b demo/more/out/dragList.css
--- 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;
 }
diff -r 6a77c3e33908 -r cc956020801b src/mono_reduce.sml
--- 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'
diff -r 6a77c3e33908 -r cc956020801b src/mono_util.sig
--- 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}
diff -r 6a77c3e33908 -r cc956020801b src/mono_util.sml
--- 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)),