Specialize: ignore recursive references in classifying polymorphic uses of datatypes

5 files changed, 56 insertions, 4 deletions

diff --git a/src/compiler.sig b/src/compiler.sig
index 7922393d..09c913f8 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -164,6 +164,7 @@ signature COMPILER = sig
     val toUnpoly2 : (string, Core.file) transform
     val toShake4'' : (string, Core.file) transform
     val toEspecialize3 : (string, Core.file) transform
+    val toSpecialize3 : (string, Core.file) transform
     val toReduce2 : (string, Core.file) transform
     val toShake5 : (string, Core.file) transform
     val toMarshalcheck : (string, Core.file) transform
diff --git a/src/compiler.sml b/src/compiler.sml
index 271cf2f1..e7de4d82 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -1390,8 +1390,9 @@ val toUnpoly2 = transform unpoly "unpoly2" o toShake4'
 val toSpecialize2 = transform specialize "specialize2" o toUnpoly2
 val toShake4'' = transform shake "shake4'" o toSpecialize2
 val toEspecialize3 = transform especialize "especialize3" o toShake4''
+val toSpecialize3 = transform specialize "specialize3" o toEspecialize3
 
-val toReduce2 = transform reduce "reduce2" o toEspecialize3
+val toReduce2 = transform reduce "reduce2" o toSpecialize3
 
 val toShake5 = transform shake "shake5" o toReduce2
 
diff --git a/src/core_util.sig b/src/core_util.sig
index 835577a3..8d295f1e 100644
--- a/src/core_util.sig
+++ b/src/core_util.sig
@@ -161,6 +161,12 @@ structure Decl : sig
                    decl : (Core.decl', 'state, 'abort) Search.mapfolder}
                   -> (Core.decl, 'state, 'abort) Search.mapfolder
 
+    val map : {kind : Core.kind' -> Core.kind',
+               con : Core.con' -> Core.con',
+               exp : Core.exp' -> Core.exp',
+               decl : Core.decl' -> Core.decl'}
+              -> Core.decl -> Core.decl
+                                                 
     val fold : {kind : Core.kind' * 'state -> 'state,
                 con : Core.con' * 'state -> 'state,
                 exp : Core.exp' * 'state -> 'state,
diff --git a/src/core_util.sml b/src/core_util.sml
index 57ef16f7..d1d3d9c4 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -1029,6 +1029,22 @@ fun mapfold {kind = fk, con = fc, exp = fe, decl = fd} =
               decl = fn () => fd,
               bind = fn ((), _) => ()} ()
 
+fun mapB {kind, con, exp, decl, bind} ctx d =
+    case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()),
+                   con = fn ctx => fn c => fn () => S.Continue (con ctx c, ()),
+                   exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
+                   decl = fn ctx => fn d => fn () => S.Continue (decl ctx d, ()),
+                   bind = bind} ctx d () of
+        S.Continue (d, ()) => d
+      | S.Return _ => raise Fail "CoreUtil.Decl.mapB: Impossible"
+
+fun map {kind, con, exp, decl} d =
+    mapB {kind = fn () => kind,
+          con = fn () => con,
+          exp = fn () => exp,
+          decl = fn () => decl,
+          bind = fn _ => ()} () d
+             
 fun fold {kind, con, exp, decl} s d =
     case mapfold {kind = fn k => fn s => S.Continue (k, kind (k, s)),
                   con = fn c => fn s => S.Continue (c, con (c, s)),
diff --git a/src/specialize.sml b/src/specialize.sml
index 9dc2cf1b..70e646e3 100644
--- a/src/specialize.sml
+++ b/src/specialize.sml
@@ -248,6 +248,27 @@ val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl}
 
 fun specialize file =
     let
+        (*val () = CorePrint.debug := true
+        val () = print "SPECIALIZING\n"*)
+                
+        (* Let's run around a file, finding any polymorphic uses of a datatype.
+         * However, don't count polymorphism within a datatype's own definition!
+         * To that end, we run a silly transform on the file before traversing. *)
+        val file' =
+            map (fn d =>
+                    case #1 d of
+                        DDatatype dts =>
+                        U.Decl.map {kind = fn x => x,
+                                    exp = fn x => x,
+                                    decl = fn x => x,
+                                    con = fn CNamed n =>
+                                             if List.exists (fn (_, n', _, _) => n' = n) dts then
+                                                 CUnit
+                                             else
+                                                 CNamed n
+                                           | c => c} d
+                      | _ => d) file
+
         val fancyDatatypes = U.File.fold {kind = fn (_, fd) => fd,
                                           exp = fn (_, fd) => fd,
                                           decl = fn (_, fd) => fd,
@@ -256,12 +277,18 @@ fun specialize file =
                                                        CApp (c1, c2) =>
                                                        if isOpen c2 then
                                                            case findApp (c, []) of
-                                                               SOME (n, _) => IS.add (fd, n)
+                                                               SOME (n, _) =>
+                                                               ((*Print.preface ("Disqualifier",
+                                                                               CorePrint.p_con CoreEnv.empty (c, ErrorMsg.dummySpan));*)
+                                                                IS.add (fd, n))
                                                              | NONE => fd
                                                        else
                                                            fd
                                                     |  _ => fd}
-                                         IS.empty file
+                                         IS.empty file'
+
+        (* Why did we find the polymorphism?
+         * It would be incoherent to specialize a datatype used polymorphically. *)
 
         fun doDecl (d, st) =
             let
@@ -271,7 +298,8 @@ fun specialize file =
                 case #1 d of
                     DDatatype dts =>
                     if List.exists (fn (_, n, _, _) => IS.member (fancyDatatypes, n)) dts then
-                        ([d], st)
+                        ((*Print.preface ("Skipping", CorePrint.p_decl CoreEnv.empty d);*)
+                         ([d], st))
                     else
                         ((case #decls st of
                               [] => [d]