Defunctionalization gets CommentBlog working

7 files changed, 330 insertions, 1 deletions

diff --git a/src/compiler.sig b/src/compiler.sig
index 6094da89..402706be 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -65,6 +65,7 @@ signature COMPILER = sig
     val especialize : (Core.file, Core.file) phase
     val core_untangle : (Core.file, Core.file) phase
     val shake : (Core.file, Core.file) phase
+    val defunc : (Core.file, Core.file) phase
     val tag : (Core.file, Core.file) phase
     val reduce : (Core.file, Core.file) phase
     val unpoly : (Core.file, Core.file) phase
@@ -89,6 +90,7 @@ signature COMPILER = sig
     val toEspecialize : (string, Core.file) transform 
     val toCore_untangle : (string, Core.file) transform
     val toShake1 : (string, Core.file) transform
+    val toDefunc : (string, Core.file) transform 
     val toTag : (string, Core.file) transform
     val toReduce : (string, Core.file) transform
     val toUnpoly : (string, Core.file) transform 
diff --git a/src/compiler.sml b/src/compiler.sml
index 9705cfaf..93a03169 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -439,12 +439,19 @@ val shake = {
 
 val toShake1 = transform shake "shake1" o toCore_untangle
 
+val defunc = {
+    func = Defunc.defunc,
+    print = CorePrint.p_file CoreEnv.empty
+}
+
+val toDefunc = transform defunc "defunc" o toShake1
+
 val tag = {
     func = Tag.tag,
     print = CorePrint.p_file CoreEnv.empty
 }
 
-val toTag = transform tag "tag" o toShake1
+val toTag = transform tag "tag" o toDefunc
 
 val reduce = {
     func = Reduce.reduce,
diff --git a/src/core_util.sig b/src/core_util.sig
index e435aeaf..100932c3 100644
--- a/src/core_util.sig
+++ b/src/core_util.sig
@@ -105,6 +105,12 @@ structure Exp : sig
                 con : Core.con' * 'state -> 'state,
                 exp : Core.exp' * 'state -> 'state}
                -> 'state -> Core.exp -> 'state
+
+    val foldB : {kind : Core.kind' * 'state -> 'state,
+                 con : 'context * Core.con' * 'state -> 'state,
+                 exp : 'context * Core.exp' * 'state -> 'state,
+                 bind : 'context * binder -> 'context}
+                -> 'context -> 'state -> Core.exp -> 'state
                                         
     val exists : {kind : Core.kind' -> bool,
                   con : Core.con' -> bool,
@@ -148,6 +154,12 @@ structure Decl : sig
                    exp : Core.exp' * 'state -> Core.exp' * 'state,
                    decl : Core.decl' * 'state -> Core.decl' * 'state}
                   -> 'state -> Core.decl -> Core.decl * 'state
+    val foldMapB : {kind : Core.kind' * 'state -> Core.kind' * 'state,
+                    con : 'context * Core.con' * 'state -> Core.con' * 'state,
+                    exp : 'context * Core.exp' * 'state -> Core.exp' * 'state,
+                    decl : 'context * Core.decl' * 'state -> Core.decl' * 'state,
+                    bind : 'context * binder -> 'context}
+                   -> 'context -> 'state -> Core.decl -> Core.decl * 'state
 end
 
 structure File : sig
diff --git a/src/core_util.sml b/src/core_util.sml
index 4d72f57e..f7e92f51 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -709,6 +709,14 @@ fun fold {kind, con, exp} s e =
         S.Continue (_, s) => s
       | S.Return _ => raise Fail "CoreUtil.Exp.fold: Impossible"
 
+fun foldB {kind, con, exp, bind} ctx s e =
+    case mapfoldB {kind = fn k => fn s => S.Continue (k, kind (k, s)),
+                  con = fn ctx => fn c => fn s => S.Continue (c, con (ctx, c, s)),
+                  exp = fn ctx => fn e => fn s => S.Continue (e, exp (ctx, e, s)),
+                  bind = bind} ctx e s of
+        S.Continue (_, s) => s
+      | S.Return _ => raise Fail "CoreUtil.Exp.foldB: Impossible"
+
 fun exists {kind, con, exp} k =
     case mapfold {kind = fn k => fn () =>
                                     if kind k then
@@ -861,6 +869,15 @@ fun foldMap {kind, con, exp, decl} s d =
         S.Continue v => v
       | S.Return _ => raise Fail "CoreUtil.Decl.foldMap: Impossible"
 
+fun foldMapB {kind, con, exp, decl, bind} ctx s d =
+    case mapfoldB {kind = fn k => fn s => S.Continue (kind (k, s)),
+                   con = fn ctx => fn c => fn s => S.Continue (con (ctx, c, s)),
+                   exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)),
+                   decl = fn ctx => fn d => fn s => S.Continue (decl (ctx, d, s)),
+                   bind = bind} ctx d s of
+        S.Continue v => v
+      | S.Return _ => raise Fail "CoreUtil.Decl.foldMapB: Impossible"
+
 end
 
 structure File = struct
diff --git a/src/defunc.sig b/src/defunc.sig
new file mode 100644
index 00000000..6e8f2136
--- /dev/null
+++ b/src/defunc.sig
@@ -0,0 +1,32 @@
+(* Copyright (c) 2008, 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 DEFUNC = sig
+
+    val defunc : Core.file -> Core.file
+
+end
diff --git a/src/defunc.sml b/src/defunc.sml
new file mode 100644
index 00000000..8771d782
--- /dev/null
+++ b/src/defunc.sml
@@ -0,0 +1,256 @@
+(* Copyright (c) 2008, 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 Defunc :> DEFUNC = struct
+
+open Core
+
+structure E = CoreEnv
+structure U = CoreUtil
+
+structure IS = IntBinarySet
+
+val functionInside = U.Con.exists {kind = fn _ => false,
+                                   con = fn TFun _ => true
+                                          | CFfi ("Basis", "transaction") => true
+                                          | _ => false}
+
+val freeVars = U.Exp.foldB {kind = fn (_, xs) => xs,
+                            con = fn (_, _, xs) => xs,
+                            exp = fn (bound, e, xs) =>
+                                     case e of
+                                         ERel x =>
+                                         if x >= bound then
+                                             IS.add (xs, x - bound)
+                                         else
+                                             xs
+                                       | _ => xs,
+                            bind = fn (bound, b) =>
+                                      case b of
+                                          U.Exp.RelE _ => bound + 1
+                                        | _ => bound}
+                           0 IS.empty
+
+fun positionOf (v : int, ls) =
+    let
+        fun pof (pos, ls) =
+            case ls of
+                [] => raise Fail "Defunc.positionOf"
+              | v' :: ls' =>
+                if v = v' then
+                    pos
+                else
+                    pof (pos + 1, ls')
+    in
+        pof (0, ls)
+    end
+
+fun squish fvs =
+    U.Exp.mapB {kind = fn k => k,
+                con = fn _ => fn c => c,
+                exp = fn bound => fn e =>
+                                     case e of
+                                         ERel x =>
+                                         if x >= bound then
+                                             ERel (positionOf (x - bound, fvs) + bound)
+                                         else
+                                             e
+                                       | _ => e,
+                bind = fn (bound, b) =>
+                          case b of
+                              U.Exp.RelE _ => bound + 1
+                            | _ => bound}
+               0
+
+fun default (_, x, st) = (x, st)
+
+datatype 'a search =
+         Yes
+       | No
+       | Maybe of 'a
+
+structure EK = struct
+type ord_key = exp
+val compare = U.Exp.compare
+end
+
+structure EM = BinaryMapFn(EK)
+
+type state = {
+     maxName : int,
+     funcs : int EM.map,
+     vis : (string * int * con * exp * string) list
+}
+
+fun exp (env, e, st) =
+    case e of
+        ERecord xes =>
+        let
+            val (xes, st) =
+                ListUtil.foldlMap
+                    (fn (tup as (fnam as (CName x, loc), e, xt), st) =>
+                         if x <> "Link" andalso x <> "Action" then
+                             (tup, st)
+                         else
+                             let
+                                 fun needsAttention (e, _) =
+                                     case e of
+                                         ENamed f => Maybe (#2 (E.lookupENamed env f))
+                                       | EApp (f, _) =>
+                                         (case needsAttention f of
+                                              No => No
+                                            | Yes => Yes
+                                            | Maybe t =>
+                                              case t of
+                                                  (TFun (dom, _), _) =>
+                                                  if functionInside dom then
+                                                      Yes
+                                                  else
+                                                      No
+                                                | _ => No)
+                                       | _ => No
+
+                                 fun headSymbol (e, _) =
+                                     case e of
+                                         ENamed f => f
+                                       | EApp (e, _) => headSymbol e
+                                       | _ => raise Fail "Defunc: headSymbol"
+
+                                 fun rtype (e, _) =
+                                     case e of
+                                         ENamed f => #2 (E.lookupENamed env f)
+                                       | EApp (f, _) =>
+                                         (case rtype f of
+                                              (TFun (_, ran), _) => ran
+                                            | _ => raise Fail "Defunc: rtype [1]")
+                                       | _ => raise Fail "Defunc: rtype [2]"
+                             in
+                                 (*Print.prefaces "Found one!"
+                                                [("e", CorePrint.p_exp env e)];*)
+                                 case needsAttention e of
+                                     Yes =>
+                                     let
+                                         (*val () = print "Yes\n"*)
+                                         val f = headSymbol e
+
+                                         val fvs = IS.listItems (freeVars e)
+
+                                         val e = squish fvs e
+                                         val (e, t) = foldl (fn (n, (e, t)) =>
+                                                                let
+                                                                    val (x, xt) = E.lookupERel env n
+                                                                in
+                                                                    ((EAbs (x, xt, t, e), loc),
+                                                                     (TFun (xt, t), loc))
+                                                                end)
+                                                            (e, rtype e) fvs
+
+                                         val (f', st) =
+                                             case EM.find (#funcs st, e) of
+                                                 SOME f' => (f', st)
+                                               | NONE =>
+                                                 let
+                                                     val (fx, _, _, tag) = E.lookupENamed env f
+                                                     val f' = #maxName st
+
+                                                     val vi = (fx, f', t, e, tag)
+                                                 in
+                                                     (f', {maxName = f' + 1,
+                                                           funcs = EM.insert (#funcs st, e, f'),
+                                                           vis = vi :: #vis st})
+                                                 end
+
+                                         val e = foldr (fn (n, e) =>
+                                                           (EApp (e, (ERel n, loc)), loc))
+                                                       (ENamed f', loc) fvs
+                                     in
+                                         (*app (fn n => Print.prefaces
+                                                            "Free"
+                                                            [("n", CorePrint.p_exp env (ERel n, ErrorMsg.dummySpan))])
+                                               fvs;
+                                          Print.prefaces "Squished"
+                                                         [("e", CorePrint.p_exp CoreEnv.empty e)];*)
+
+                                         ((fnam, e, xt), st)
+                                     end
+                                   | _ => (tup, st)
+                             end
+                      | (tup, st) => (tup, st))
+                st xes
+        in
+            (ERecord xes, st)
+        end
+      | _ => (e, st)
+
+fun bind (env, b) =
+    case b of
+        U.Decl.RelC (x, k) => E.pushCRel env x k
+      | U.Decl.NamedC (x, n, k, co) => E.pushCNamed env x n k co
+      | U.Decl.RelE (x, t) => E.pushERel env x t
+      | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s
+
+fun doDecl env = U.Decl.foldMapB {kind = fn x => x,
+                                  con = default,
+                                  exp = exp,
+                                  decl = default,
+                                  bind = bind}
+                                 env
+
+fun defunc file =
+    let
+        fun doDecl' (d, (env, st)) =
+            let
+                val env = E.declBinds env d
+
+                val (d, st) = doDecl env st d
+
+                val ds =
+                    case #vis st of
+                        [] => [d]
+                      | vis =>
+                        case d of
+                            (DValRec vis', loc) => [(DValRec (vis' @ vis), loc)]
+                          | _ => [(DValRec vis, #2 d), d]
+            in
+                (ds,
+                 (env,
+                  {maxName = #maxName st,
+                   funcs = #funcs st,
+                   vis = []}))
+            end
+
+        val (file, _) = ListUtil.foldlMapConcat doDecl'
+                        (E.empty,
+                         {maxName = U.File.maxName file + 1,
+                          funcs = EM.empty,
+                          vis = []})
+                        file
+    in
+        file
+    end
+
+end
diff --git a/src/sources b/src/sources
index 252ffe44..bddcac67 100644
--- a/src/sources
+++ b/src/sources
@@ -105,6 +105,9 @@ especialize.sml
 core_untangle.sig
 core_untangle.sml
 
+defunc.sig
+defunc.sml
+
 tag.sig
 tag.sml