From 489ae9fdc1b78eac867252e5088baa632d85f8c9 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Tue, 15 Dec 2009 19:26:52 -0500
Subject: Especialize uses a termination measure based on number of arguments
 introduced

---
 demo/tree.ur        |   2 +-
 src/compiler.sig    |   2 +
 src/compiler.sml    |  10 +++++
 src/demo.sig        |   1 +
 src/demo.sml        |  26 ++++++++----
 src/especialize.sml | 119 +++++++++++++++++++++++++---------------------------
 tests/espec.ur      |  56 -------------------------
 tests/espec.urp     |   3 --
 tests/espec.urs     |   1 -
 9 files changed, 90 insertions(+), 130 deletions(-)
 delete mode 100644 tests/espec.ur
 delete mode 100644 tests/espec.urp
 delete mode 100644 tests/espec.urs

diff --git a/demo/tree.ur b/demo/tree.ur
index 0a13e470..6cb5051c 100644
--- a/demo/tree.ur
+++ b/demo/tree.ur
@@ -4,9 +4,9 @@ table t : { Id : int, Parent : option int, Nam : string }
   CONSTRAINT F FOREIGN KEY Parent REFERENCES t (Id) ON DELETE CASCADE
 
 open TreeFun.Make(struct
-                      val tab = t
                       con id = #Id
                       con parent = #Parent
+                      val tab = t
                   end)
 
 fun row r = <xml>
diff --git a/src/compiler.sig b/src/compiler.sig
index 1a41eaea..2b08bff4 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -152,4 +152,6 @@ signature COMPILER = sig
     val toChecknest : (string, Cjr.file) transform
     val toSqlify : (string, Cjr.file) transform
 
+    val debug : bool ref
+
 end
diff --git a/src/compiler.sml b/src/compiler.sml
index 256162ce..baf8ddac 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -71,10 +71,20 @@ type ('src, 'dst) transform = {
      time : 'src * pmap -> 'dst option * pmap
 }
 
+val debug = ref false
+
 fun transform (ph : ('src, 'dst) phase) name = {
     func = fn input => let
+                  val () = if !debug then
+                               print ("Starting " ^ name ^ "....\n")
+                           else
+                               ()
                   val v = #func ph input
               in
+                  if !debug then
+                      print ("Finished " ^ name ^ ".\n")
+                  else
+                      ();
                   if ErrorMsg.anyErrors () then
                       NONE
                   else
diff --git a/src/demo.sig b/src/demo.sig
index 4bb4a19e..5f5fa2bb 100644
--- a/src/demo.sig
+++ b/src/demo.sig
@@ -28,5 +28,6 @@
 signature DEMO = sig
 
     val make : {prefix : string, dirname : string, guided : bool} -> unit
+    val make' : {prefix : string, dirname : string, guided : bool} -> bool
 
 end
diff --git a/src/demo.sml b/src/demo.sml
index c5480a93..55615173 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -27,7 +27,7 @@
 
 structure Demo :> DEMO = struct
 
-fun make {prefix, dirname, guided} =
+fun make' {prefix, dirname, guided} =
     let
         val prose = OS.Path.joinDirFile {dir = dirname,
                                          file = "prose"}
@@ -430,13 +430,23 @@ fun make {prefix, dirname, guided} =
 
                 TextIO.closeOut outf;
 
-                Compiler.compiler (OS.Path.base fname)
-            end;
-
-        TextIO.output (demosOut, "\n</body></html>\n");
-        TextIO.closeOut demosOut;
-
-        prettyPrint ()
+                let
+                    val b = Compiler.compile (OS.Path.base fname)
+                in
+                    TextIO.output (demosOut, "\n</body></html>\n");
+                    TextIO.closeOut demosOut;
+                    if b then
+                        prettyPrint ()
+                    else
+                        ();
+                    b
+                end
+            end
     end
 
+fun make args = if make' args then
+                    ()
+                else
+                    OS.Process.exit OS.Process.failure
+
 end
diff --git a/src/especialize.sml b/src/especialize.sml
index 7cadb905..46105d90 100644
--- a/src/especialize.sml
+++ b/src/especialize.sml
@@ -79,14 +79,14 @@ fun positionOf (v : int, ls) =
         pof (0, ls)
     end
 
-fun squish (untouched, fvs) =
+fun squish fvs =
     U.Exp.mapB {kind = fn _ => 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 + untouched)
+                                             ERel (positionOf (x - bound, fvs) + bound)
                                          else
                                              e
                                        | _ => e,
@@ -107,7 +107,8 @@ type func = {
 type state = {
      maxName : int,
      funcs : func IM.map,
-     decls : (string * int * con * exp * string) list
+     decls : (string * int * con * exp * string) list,
+     specialized : bool IM.map
 }
 
 fun default (_, x, st) = (x, st)
@@ -119,7 +120,7 @@ structure SS = BinarySetFn(struct
 
 val mayNotSpec = ref SS.empty
 
-fun specialize' file =
+fun specialize' specialized file =
     let
         fun bind (env, b) =
             case b of
@@ -165,51 +166,45 @@ fun specialize' file =
                                                                       | _ => false}
                             val loc = ErrorMsg.dummySpan
 
-                            fun hasFuncArg t =
-                                case #1 t of
-                                    TFun (dom, ran) => functionInside dom orelse hasFuncArg ran
-                                  | _ => false
-
-                            fun findSplit hfa (xs, typ, fxs, fvs, ts) =
+                            fun findSplit av (xs, typ, fxs, fvs) =
                                 case (#1 typ, xs) of
                                     (TFun (dom, ran), e :: xs') =>
                                     let
-                                        val isVar = case #1 e of
-                                                        ERel _ => true
-                                                      | _ => false
-                                        val hfa = hfa andalso isVar
+                                        val av = case #1 e of
+                                                     ERel _ => av
+                                                   | _ => false
                                     in
-                                        if hfa orelse functionInside dom then
-                                            findSplit hfa (xs',
-                                                           ran,
-                                                           (true, e) :: fxs,
-                                                           IS.union (fvs, freeVars e),
-                                                           ts)
+                                        if functionInside dom orelse (av andalso case #1 e of
+                                                                                     ERel _ => true
+                                                                                   | _ => false) then
+                                            findSplit av (xs',
+                                                          ran,
+                                                          e :: fxs,
+                                                          IS.union (fvs, freeVars e))
                                         else
-                                            findSplit hfa (xs', ran, (false, e) :: fxs, fvs, dom :: ts)
+                                            (rev fxs, xs, fvs)
                                     end
-                                  | _ => (List.revAppend (fxs, map (fn e => (false, e)) xs), fvs, rev ts)
+                                  | _ => (rev fxs, xs, fvs)
+
+                            val (fxs, xs, fvs) = findSplit true (xs, typ, [], IS.empty)
 
-                            val (xs, fvs, ts) = findSplit (hasFuncArg typ) (xs, typ, [], IS.empty, [])
-                            val fxs = List.mapPartial (fn (true, e) => SOME e | _ => NONE) xs
-                            val untouched = length (List.filter (fn (false, _) => true | _ => false) xs)
-                            val squish = squish (untouched, IS.listItems fvs)
-                            val fxs' = map squish fxs
+                            val fxs' = map (squish (IS.listItems fvs)) fxs
                         in
                             (*Print.preface ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs');*)
-                            if List.all (fn (false, _) => true
-                                          | (true, (ERel _, _)) => true
-                                          | _ => false) xs then
+                            if List.all (fn (ERel _, _) => true
+                                          | _ => false) fxs'
+                               orelse (IS.numItems fvs >= length fxs
+                                       andalso IS.exists (fn n => functionInside (#2 (List.nth (env, n)))) fvs) then
                                 (e, st)
                             else
-                                case (KM.find (args, fxs'), SS.member (!mayNotSpec, name)) of
+                                case (KM.find (args, fxs'),
+                                      SS.member (!mayNotSpec, name) orelse IM.find (#specialized st, f) = SOME true) of
                                     (SOME f', _) =>
                                     let
                                         val e = (ENamed f', loc)
                                         val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
                                                          e fvs
-                                        val e = foldl (fn ((false, arg), e) => (EApp (e, arg), loc)
-                                                        | (_, e) => e)
+                                        val e = foldl (fn (arg, e) => (EApp (e, arg), loc))
                                                       e xs
                                     in
                                         (*Print.prefaces "Brand new (reuse)"
@@ -231,24 +226,20 @@ fun specialize' file =
                                                                 [("fxs'",
                                                                   Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')]*)
 
-                                        fun subBody (body, typ, xs) =
-                                            case (#1 body, #1 typ, xs) of
+                                        fun subBody (body, typ, fxs') =
+                                            case (#1 body, #1 typ, fxs') of
                                                 (_, _, []) => SOME (body, typ)
-                                              | (EAbs (_, _, _, body'), TFun (_, typ'), (b, x) :: xs) =>
+                                              | (EAbs (_, _, _, body'), TFun (_, typ'), x :: fxs'') =>
                                                 let
-                                                    val body'' =
-                                                        if b then
-                                                            E.subExpInExp (0, squish x) body'
-                                                        else
-                                                            body'
+                                                    val body'' = E.subExpInExp (0, x) body'
                                                 in
                                                     subBody (body'',
                                                              typ',
-                                                             xs)
+                                                             fxs'')
                                                 end
                                               | _ => NONE
                                     in
-                                        case subBody (body, typ, xs) of
+                                        case subBody (body, typ, fxs') of
                                             NONE => (e, st)
                                           | SOME (body', typ') =>
                                             let
@@ -259,10 +250,17 @@ fun specialize' file =
                                                                                       body = body,
                                                                                       typ = typ,
                                                                                       tag = tag})
+
+                                                val specialized = IM.insert (#specialized st, f', false)
+                                                val specialized = case IM.find (specialized, f) of
+                                                                      NONE => specialized
+                                                                    | SOME _ => IM.insert (specialized, f, true)
+
                                                 val st = {
                                                     maxName = f' + 1,
                                                     funcs = funcs,
-                                                    decls = #decls st
+                                                    decls = #decls st,
+                                                    specialized = specialized
                                                 }
 
                                                 (*val () = Print.prefaces "specExp"
@@ -272,12 +270,6 @@ fun specialize' file =
                                                                          ("fxs'", Print.p_list
                                                                                       (CorePrint.p_exp E.empty) fxs'),
                                                                          ("e", CorePrint.p_exp env (e, loc))]*)
-
-                                                val (body', typ') = foldr (fn (t, (body', typ')) =>
-                                                                              ((EAbs ("x", t, typ', body'), loc),
-                                                                               (TFun (t, typ'), loc)))
-                                                                          (body', typ') ts
-
                                                 val (body', typ') = IS.foldl (fn (n, (body', typ')) =>
                                                                                  let
                                                                                      val (x, xt) = List.nth (env, n)
@@ -296,8 +288,7 @@ fun specialize' file =
                                                 val e' = (ENamed f', loc)
                                                 val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
                                                                   e' fvs
-                                                val e' = foldl (fn ((false, arg), e) => (EApp (e, arg), loc)
-                                                                 | (_, e) => e)
+                                                val e' = foldl (fn (arg, e) => (EApp (e, arg), loc))
                                                                e' xs
                                                 (*val () = Print.prefaces "Brand new"
                                                                         [("e'", CorePrint.p_exp CoreEnv.empty e'),
@@ -307,7 +298,8 @@ fun specialize' file =
                                                 (#1 e',
                                                  {maxName = #maxName st,
                                                   funcs = #funcs st,
-                                                  decls = (name, f', typ', body', tag) :: #decls st})
+                                                  decls = (name, f', typ', body', tag) :: #decls st,
+                                                  specialized = #specialized st})
                                             end
                                     end
                         end
@@ -336,7 +328,8 @@ fun specialize' file =
 
                 val st = {maxName = #maxName st,
                           funcs = funcs,
-                          decls = []}
+                          decls = [],
+                          specialized = #specialized st}
 
                 (*val () = Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)]*)
 
@@ -381,25 +374,27 @@ fun specialize' file =
                                          ("d'", CorePrint.p_decl E.empty d')];*)
                 (ds, ({maxName = #maxName st,
                        funcs = funcs,
-                       decls = []}, changed))
+                       decls = [],
+                       specialized = #specialized st}, changed))
             end
 
-        val (ds, (_, changed)) = ListUtil.foldlMapConcat doDecl
+        val (ds, (st, changed)) = ListUtil.foldlMapConcat doDecl
                                                             ({maxName = U.File.maxName file + 1,
                                                               funcs = IM.empty,
-                                                              decls = []},
+                                                              decls = [],
+                                                              specialized = specialized},
                                                              false)
                                                             file
     in
-        (changed, ds)
+        (changed, ds, #specialized st)
     end
 
-fun specialize file =
+fun specializeL specialized file =
     let
         val file = ReduceLocal.reduce file
         (*val () = Print.prefaces "Intermediate" [("file", CorePrint.p_file CoreEnv.empty file)]*)
         (*val file = ReduceLocal.reduce file*)
-        val (changed, file) = specialize' file
+        val (changed, file, specialized) = specialize' specialized file
         (*val file = ReduceLocal.reduce file
         val file = CoreUntangle.untangle file
         val file = Shake.shake file*)
@@ -414,10 +409,12 @@ fun specialize file =
                 val file = Shake.shake file
             in
                 (*print "Again!\n";*)
-                specialize file
+                specializeL specialized file
             end
         else
             file
     end
 
+val specialize = specializeL IM.empty
+
 end
diff --git a/tests/espec.ur b/tests/espec.ur
deleted file mode 100644
index 37b22a36..00000000
--- a/tests/espec.ur
+++ /dev/null
@@ -1,56 +0,0 @@
-fun foo (wrap : xbody -> transaction page) = wrap <xml>
-  <a link={foo wrap}>Foo</a>
-</xml>
-
-fun bar (wrap : xbody -> transaction page) (n : int) = wrap <xml>
-  <a link={bar wrap n}>Bar</a>; {[n]}
-</xml>
-
-fun baz (n : int) (wrap : xbody -> transaction page) = wrap <xml>
-  <a link={baz n wrap}>Baz</a>; {[n]}
-</xml>
-
-fun middle (n : int) (wrap : xbody -> transaction page) (m : int) = wrap <xml>
-  <a link={middle n wrap m}>Middle</a>; {[n]}; {[m]}
-</xml>
-
-fun crazy (f : int -> int) (b : bool) (wrap : xbody -> transaction page) (m : int) = wrap <xml>
-  <a link={crazy f b wrap m}>Crazy</a>; {[b]}; {[f m]}
-</xml>
-
-fun wild (q : bool) (f : int -> int) (n : float) (wrap : xbody -> transaction page) (m : int) = wrap <xml>
-  <a link={wild q f n wrap m}>Wild</a>; {[n]}; {[f m]}; {[q]}
-</xml>
-
-fun wrap x = return <xml><body>{x}</body></xml>
-
-fun wrapN n x = return <xml><body>{[n]}; {x}</body></xml>
-
-fun foo2 (wrap : xbody -> transaction page) = wrap <xml>
-  <a link={foo2 wrap}>Foo</a>
-</xml>
-
-fun foo3 (n : int) = wrap <xml>
-  <a link={foo2 (wrapN n)}>Foo</a>
-</xml>
-
-fun bar2 (n : int) (wrap : xbody -> transaction page) = wrap <xml>
-  <a link={bar2 n wrap}>Bar</a>; n={[n]}
-</xml>
-
-fun bar3 (n : int) = wrap <xml>
-  <a link={bar2 88 (wrapN n)}>Bar</a>
-</xml>
-
-
-fun main () = return <xml><body>
-  <a link={foo wrap}>Foo</a>
-  <a link={bar wrap 32}>Bar</a>
-  <a link={baz 18 wrap}>Baz</a>
-  <a link={middle 1 wrap 2}>Middle</a>
-  <a link={crazy (fn n => 2 * n) False wrap 2}>Crazy</a>
-  <a link={wild True (fn n => 2 * n) 1.23 wrap 2}>Wild</a>
-  <hr/>
-  <a link={foo3 15}>Foo3</a>
-  <a link={bar3 44}>Bar3</a>
-</body></xml>
diff --git a/tests/espec.urp b/tests/espec.urp
deleted file mode 100644
index 045fb1e0..00000000
--- a/tests/espec.urp
+++ /dev/null
@@ -1,3 +0,0 @@
-debug
-
-espec
diff --git a/tests/espec.urs b/tests/espec.urs
deleted file mode 100644
index 6ac44e0b..00000000
--- a/tests/espec.urs
+++ /dev/null
@@ -1 +0,0 @@
-val main : unit -> transaction page
-- 
cgit v1.2.3