Grid changed to use Dlist.replace; filters stopped working

6 files changed, 255 insertions, 123 deletions

diff --git a/src/compiler.sig b/src/compiler.sig
index 7ce19580..c78a2773 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -86,6 +86,7 @@ signature COMPILER = sig
     val reduce : (Core.file, Core.file) phase
     val unpoly : (Core.file, Core.file) phase
     val specialize : (Core.file, Core.file) phase
+    val tailify : (Core.file, Core.file) phase
     val marshalcheck : (Core.file, Core.file) phase
     val effectize : (Core.file, Core.file) phase
     val monoize : (Core.file, Mono.file) phase
@@ -120,6 +121,7 @@ signature COMPILER = sig
     val toSpecialize : (string, Core.file) transform 
     val toShake3 : (string, Core.file) transform
     val toEspecialize : (string, Core.file) transform 
+    val toTailify : (string, Core.file) transform
     val toReduce2 : (string, Core.file) transform
     val toShake4 : (string, Core.file) transform
     val toMarshalcheck : (string, Core.file) transform
diff --git a/src/compiler.sml b/src/compiler.sml
index bb1a6add..67ce962e 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -779,7 +779,14 @@ val toShake3 = transform shake "shake3" o toSpecialize
 
 val toEspecialize = transform especialize "especialize" o toShake3
 
-val toReduce2 = transform reduce "reduce2" o toEspecialize
+val tailify = {
+    func = Tailify.frob,
+    print = CorePrint.p_file CoreEnv.empty
+}
+
+val toTailify = transform tailify "tailify" o toEspecialize
+
+val toReduce2 = transform reduce "reduce2" o toTailify
 
 val toShake4 = transform shake "shake4" o toReduce2
 
diff --git a/src/rpcify.sml b/src/rpcify.sml
index 4ed90228..0e5a1076 100644
--- a/src/rpcify.sml
+++ b/src/rpcify.sml
@@ -32,26 +32,12 @@ open Core
 structure U = CoreUtil
 structure E = CoreEnv
 
-fun multiLiftExpInExp n e =
-    if n = 0 then
-        e
-    else
-        multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e)
-
 structure IS = IntBinarySet
 structure IM = IntBinaryMap
 
-structure SS = BinarySetFn(struct
-                           type ord_key = string
-                           val compare = String.compare
-                           end)
-
 type state = {
      exported : IS.set,
-     export_decls : decl list,
-
-     cpsed : exp' IM.map,
-     rpc : IS.set
+     export_decls : decl list
 }
 
 fun frob file =
@@ -124,9 +110,7 @@ fun frob file =
                                          (DExport (Rpc ReadWrite, n), loc) :: #export_decls st)
 
                                 val st = {exported = exported,
-                                          export_decls = export_decls,
-                                          cpsed = #cpsed st,
-                                          rpc = #rpc st}
+                                          export_decls = export_decls}
 
                                 val k = (ECApp ((EFfi ("Basis", "return"), loc),
                                                 (CFfi ("Basis", "transaction"), loc)), loc)
@@ -145,11 +129,6 @@ fun frob file =
                     else
                         (e, st)
 
-                  | ENamed n =>
-                    (case IM.find (#cpsed st, n) of
-                         NONE => (e, st)
-                       | SOME re => (re, st))
-
                   | _ => (e, st)
             end
 
@@ -159,99 +138,6 @@ fun frob file =
 
         fun decl (d, st : state) =
             let
-                val makesServerCall = U.Exp.exists {kind = fn _ => false,
-                                                    con = fn _ => false,
-                                                    exp = fn EFfi ("Basis", "rpc") => true
-                                                           | ENamed n => IS.member (#rpc st, n)
-                                                           | _ => false}
-
-                val (d, st) =
-                    case #1 d of
-                        DValRec vis =>
-                        if List.exists (fn (_, _, _, e, _) => makesServerCall e) vis then
-                            let
-                                val rpc = foldl (fn ((_, n, _, _, _), rpc) =>
-                                                    IS.add (rpc, n)) (#rpc st) vis
-
-                                val (cpsed, vis') =
-                                    foldl (fn (vi as (x, n, t, e, s), (cpsed, vis')) =>
-                                              let
-                                                  fun getArgs (t, acc) =
-                                                      case #1 t of
-                                                          TFun (dom, ran) =>
-                                                          getArgs (ran, dom :: acc)
-                                                        | _ => (rev acc, t)
-                                                  val (ts, ran) = getArgs (t, [])
-                                                  val ran = case #1 ran of
-                                                                CApp (_, ran) => ran
-                                                              | _ => raise Fail "Rpcify: Tail function not transactional"
-                                                  val len = length ts
-
-                                                  val loc = #2 e
-                                                  val args = ListUtil.mapi
-                                                                 (fn (i, _) =>
-                                                                     (ERel (len - i - 1), loc))
-                                                                 ts
-                                                  val k = (EFfi ("Basis", "return"), loc)
-                                                  val trans = (CFfi ("Basis", "transaction"), loc)
-                                                  val k = (ECApp (k, trans), loc)
-                                                  val k = (ECApp (k, ran), loc)
-                                                  val k = (EApp (k, (EFfi ("Basis", "transaction_monad"),
-                                                                     loc)), loc)
-                                                  val re = (ETailCall (n, args, k, ran, ran), loc)
-                                                  val (re, _) = foldr (fn (dom, (re, ran)) =>
-                                                                          ((EAbs ("x", dom, ran, re),
-                                                                            loc),
-                                                                           (TFun (dom, ran), loc)))
-                                                                      (re, ran) ts
-
-                                                  val be = multiLiftExpInExp (len + 1) e
-                                                  val be = ListUtil.foldli
-                                                               (fn (i, _, be) =>
-                                                                   (EApp (be, (ERel (len - i), loc)), loc))
-                                                               be ts
-                                                  val ne = (EFfi ("Basis", "bind"), loc)
-                                                  val ne = (ECApp (ne, trans), loc)
-                                                  val ne = (ECApp (ne, ran), loc)
-                                                  val unit = (TRecord (CRecord ((KType, loc), []),
-                                                                       loc), loc)
-                                                  val ne = (ECApp (ne, unit), loc)
-                                                  val ne = (EApp (ne, (EFfi ("Basis", "transaction_monad"),
-                                                                       loc)), loc)
-                                                  val ne = (EApp (ne, be), loc)
-                                                  val ne = (EApp (ne, (ERel 0, loc)), loc)
-                                                  val tunit = (CApp (trans, unit), loc)
-                                                  val kt = (TFun (ran, tunit), loc)
-                                                  val ne = (EAbs ("k", kt, tunit, ne), loc)
-                                                  val (ne, res) = foldr (fn (dom, (ne, ran)) =>
-                                                                            ((EAbs ("x", dom, ran, ne), loc),
-                                                                             (TFun (dom, ran), loc)))
-                                                                        (ne, (TFun (kt, tunit), loc)) ts
-                                              in
-                                                  (IM.insert (cpsed, n, #1 re),
-                                                   (x, n, res, ne, s) :: vis')
-                                              end)
-                                          (#cpsed st, []) vis
-                            in
-                                ((DValRec (rev vis'), ErrorMsg.dummySpan),
-                                 {exported = #exported st,
-                                  export_decls = #export_decls st,
-                                  cpsed = cpsed,
-                                  rpc = rpc})
-                            end
-                        else
-                            (d, st)
-                      | DVal (x, n, t, e, s) =>
-                        (d,
-                         {exported = #exported st,
-                          export_decls = #export_decls st,
-                          cpsed = #cpsed st,
-                          rpc = if makesServerCall e then
-                                    IS.add (#rpc st, n)
-                                else
-                                    #rpc st})
-                      | _ => (d, st)
-
                 val (d, st) = U.Decl.foldMap {kind = fn x => x,
                                               con = fn x => x,
                                               exp = exp,
@@ -260,16 +146,12 @@ fun frob file =
             in
                 (#export_decls st @ [d],
                  {exported = #exported st,
-                  export_decls = [],
-                  cpsed = #cpsed st,
-                  rpc = #rpc st})
+                  export_decls = []})
             end
 
         val (file, _) = ListUtil.foldlMapConcat decl
                         {exported = IS.empty,
-                         export_decls = [],
-                         cpsed = IM.empty,
-                         rpc = rpcBaseIds}
+                         export_decls = []}
                         file
     in
         file
diff --git a/src/sources b/src/sources
index ddc7deff..54910b8f 100644
--- a/src/sources
+++ b/src/sources
@@ -131,6 +131,9 @@ especialize.sml
 rpcify.sig
 rpcify.sml
 
+tailify.sig
+tailify.sml
+
 tag.sig
 tag.sml
 
diff --git a/src/tailify.sig b/src/tailify.sig
new file mode 100644
index 00000000..c0d1fb35
--- /dev/null
+++ b/src/tailify.sig
@@ -0,0 +1,32 @@
+(* Copyright (c) 2009, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+signature TAILIFY = sig
+
+    val frob : Core.file -> Core.file
+
+end
diff --git a/src/tailify.sml b/src/tailify.sml
new file mode 100644
index 00000000..4b086e09
--- /dev/null
+++ b/src/tailify.sml
@@ -0,0 +1,206 @@
+(* Copyright (c) 2009, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+structure Tailify :> TAILIFY = struct
+
+open Core
+
+structure U = CoreUtil
+structure E = CoreEnv
+
+fun multiLiftExpInExp n e =
+    if n = 0 then
+        e
+    else
+        multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e)
+
+structure IS = IntBinarySet
+structure IM = IntBinaryMap
+
+type state = {
+     cpsed : exp' IM.map,
+     rpc : IS.set
+}
+
+fun frob file =
+    let
+        fun exp (e, st : state) =
+            case e of
+                ENamed n =>
+                (case IM.find (#cpsed st, n) of
+                     NONE => (e, st)
+                   | SOME re => (re, st))
+                
+              | _ => (e, st)
+
+        and doExp (e, st) = U.Exp.foldMap {kind = fn x => x,
+                                           con = fn x => x,
+                                           exp = exp} st (ReduceLocal.reduceExp e)
+
+        fun decl (d, st : state) =
+            let
+                fun makesServerCall b (e, _) =
+                    case e of
+                        EServerCall _ => true
+                      | ETailCall _ => raise Fail "Tailify: ETailCall too early"
+                      | ENamed n => IS.member (#rpc st, n)
+
+                      | EPrim _ => false
+                      | ERel n => List.nth (b, n)
+                      | ECon (_, _, _, NONE) => false
+                      | ECon (_, _, _, SOME e) => makesServerCall b e
+                      | EFfi _ => false
+                      | EFfiApp (_, _, es) => List.exists (makesServerCall b) es
+                      | EApp (e1, e2) => makesServerCall b e1 orelse makesServerCall b e2
+                      | EAbs (_, _, _, e1) => makesServerCall (false :: b) e1
+                      | ECApp (e1, _) => makesServerCall b e1
+                      | ECAbs (_, _, e1) => makesServerCall b e1
+
+                      | EKAbs (_, e1) => makesServerCall b e1
+                      | EKApp (e1, _) => makesServerCall b e1
+
+                      | ERecord xes => List.exists (fn ((CName s, _), e, _) =>
+                                                       not (String.isPrefix "On" s) andalso makesServerCall b e
+                                                     | (_, e, _) => makesServerCall b e) xes
+                      | EField (e1, _, _) => makesServerCall b e1
+                      | EConcat (e1, _, e2, _) => makesServerCall b e1 orelse makesServerCall b e2
+                      | ECut (e1, _, _) => makesServerCall b e1
+                      | ECutMulti (e1, _, _) => makesServerCall b e1
+
+                      | ECase (e1, pes, _) => makesServerCall b e1
+                                              orelse List.exists (fn (p, e) =>
+                                                                     makesServerCall (List.tabulate (E.patBindsN p,
+                                                                                                  fn _ => false) @ b)
+                                                                                     e) pes
+
+                      | EWrite e1 => makesServerCall b e1
+
+                      | EClosure (_, es) => List.exists (makesServerCall b) es
+
+                      | ELet (_, _, e1, e2) => makesServerCall (makesServerCall b e1 :: b) e2
+
+                val makesServerCall = makesServerCall []
+
+                val (d, st) =
+                    case #1 d of
+                        DValRec vis =>
+                        if List.exists (fn (_, _, _, e, _) => makesServerCall e) vis then
+                            let
+                                val rpc = foldl (fn ((_, n, _, _, _), rpc) =>
+                                                    IS.add (rpc, n)) (#rpc st) vis
+
+                                val (cpsed, vis') =
+                                    foldl (fn (vi as (x, n, t, e, s), (cpsed, vis')) =>
+                                              let
+                                                  fun getArgs (t, acc) =
+                                                      case #1 t of
+                                                          TFun (dom, ran) =>
+                                                          getArgs (ran, dom :: acc)
+                                                        | _ => (rev acc, t)
+                                                  val (ts, ran) = getArgs (t, [])
+                                                  val ran = case #1 ran of
+                                                                CApp (_, ran) => ran
+                                                              | _ => raise Fail "Rpcify: Tail function not transactional"
+                                                  val len = length ts
+
+                                                  val loc = #2 e
+                                                  val args = ListUtil.mapi
+                                                                 (fn (i, _) =>
+                                                                     (ERel (len - i - 1), loc))
+                                                                 ts
+                                                  val k = (EFfi ("Basis", "return"), loc)
+                                                  val trans = (CFfi ("Basis", "transaction"), loc)
+                                                  val k = (ECApp (k, trans), loc)
+                                                  val k = (ECApp (k, ran), loc)
+                                                  val k = (EApp (k, (EFfi ("Basis", "transaction_monad"),
+                                                                     loc)), loc)
+                                                  val re = (ETailCall (n, args, k, ran, ran), loc)
+                                                  val (re, _) = foldr (fn (dom, (re, ran)) =>
+                                                                          ((EAbs ("x", dom, ran, re),
+                                                                            loc),
+                                                                           (TFun (dom, ran), loc)))
+                                                                      (re, ran) ts
+
+                                                  val be = multiLiftExpInExp (len + 1) e
+                                                  val be = ListUtil.foldli
+                                                               (fn (i, _, be) =>
+                                                                   (EApp (be, (ERel (len - i), loc)), loc))
+                                                               be ts
+                                                  val ne = (EFfi ("Basis", "bind"), loc)
+                                                  val ne = (ECApp (ne, trans), loc)
+                                                  val ne = (ECApp (ne, ran), loc)
+                                                  val unit = (TRecord (CRecord ((KType, loc), []),
+                                                                       loc), loc)
+                                                  val ne = (ECApp (ne, unit), loc)
+                                                  val ne = (EApp (ne, (EFfi ("Basis", "transaction_monad"),
+                                                                       loc)), loc)
+                                                  val ne = (EApp (ne, be), loc)
+                                                  val ne = (EApp (ne, (ERel 0, loc)), loc)
+                                                  val tunit = (CApp (trans, unit), loc)
+                                                  val kt = (TFun (ran, tunit), loc)
+                                                  val ne = (EAbs ("k", kt, tunit, ne), loc)
+                                                  val (ne, res) = foldr (fn (dom, (ne, ran)) =>
+                                                                            ((EAbs ("x", dom, ran, ne), loc),
+                                                                             (TFun (dom, ran), loc)))
+                                                                        (ne, (TFun (kt, tunit), loc)) ts
+                                              in
+                                                  (IM.insert (cpsed, n, #1 re),
+                                                   (x, n, res, ne, s) :: vis')
+                                              end)
+                                          (#cpsed st, []) vis
+                            in
+                                ((DValRec (rev vis'), ErrorMsg.dummySpan),
+                                 {cpsed = cpsed,
+                                  rpc = rpc})
+                            end
+                        else
+                            (d, st)
+                      | DVal (x, n, t, e, s) =>
+                        (d,
+                         {cpsed = #cpsed st,
+                          rpc = if makesServerCall e then
+                                    IS.add (#rpc st, n)
+                                else
+                                    #rpc st})
+                      | _ => (d, st)
+            in
+                U.Decl.foldMap {kind = fn x => x,
+                                con = fn x => x,
+                                exp = exp,
+                                decl = fn x => x}
+                               st d
+            end
+
+        val (file, _) = ListUtil.foldlMap decl
+                        {cpsed = IM.empty,
+                         rpc = IS.empty}
+                        file
+    in
+        file
+    end
+
+end