Do dependency analysis when kind-checking type declarations

[ghc-hetmet.git] / compiler / typecheck / TcTyDecls.lhs

diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index 11b9c3b..a9ea11a 100644 (file)
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -31,6 +31,8 @@ import Digraph
 import BasicTypes
 import SrcLoc
 import Outputable
+import Util ( isSingleton )
+import Data.List
 \end{code}
 
 
@@ -102,7 +104,7 @@ synTyConsOfType ty
 \begin{code}
 calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
 calcSynCycles decls
-  = stronglyConnComp syn_edges
+  = stronglyConnCompFromEdgedVertices syn_edges
   where
     syn_edges = [ (ldecl, unLoc (tcdLName decl),
                           mk_syn_edges (tcdSynRhs decl))
@@ -114,7 +116,7 @@ calcSynCycles decls
 
 calcClassCycles :: [LTyClDecl Name] -> [[LTyClDecl Name]]
 calcClassCycles decls
-  = [decls | CyclicSCC decls <- stronglyConnComp cls_edges]
+  = [decls | CyclicSCC decls <- stronglyConnCompFromEdgedVertices cls_edges]
   where
     cls_edges = [ (ldecl, unLoc (tcdLName decl),
                           mk_cls_edges (unLoc (tcdCtxt decl)))
@@ -130,6 +132,42 @@ calcClassCycles decls
 %*                                                                      *
 %************************************************************************
 
+Identification of recursive TyCons
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
+@TyThing@s.
+
+Identifying a TyCon as recursive serves two purposes
+
+1.  Avoid infinite types.  Non-recursive newtypes are treated as
+"transparent", like type synonyms, after the type checker.  If we did
+this for all newtypes, we'd get infinite types.  So we figure out for
+each newtype whether it is "recursive", and add a coercion if so.  In
+effect, we are trying to "cut the loops" by identifying a loop-breaker.
+
+2.  Avoid infinite unboxing.  This is nothing to do with newtypes.
+Suppose we have
+        data T = MkT Int T
+        f (MkT x t) = f t
+Well, this function diverges, but we don't want the strictness analyser
+to diverge.  But the strictness analyser will diverge because it looks
+deeper and deeper into the structure of T.   (I believe there are
+examples where the function does something sane, and the strictness
+analyser still diverges, but I can't see one now.)
+
+Now, concerning (1), the FC2 branch currently adds a coercion for ALL
+newtypes.  I did this as an experiment, to try to expose cases in which
+the coercions got in the way of optimisations.  If it turns out that we
+can indeed always use a coercion, then we don't risk recursive types,
+and don't need to figure out what the loop breakers are.
+
+For newtype *families* though, we will always have a coercion, so they
+are always loop breakers!  So you can easily adjust the current
+algorithm by simply treating all newtype families as loop breakers (and
+indeed type families).  I think.
+
+
+
 For newtypes, we label some as "recursive" such that
 
     INVARIANT: there is no cycle of non-recursive newtypes
@@ -158,6 +196,7 @@ T's source module is compiled.  We don't want T's recursiveness to change.
 The "recursive" flag for algebraic data types is irrelevant (never consulted)
 for types with more than one constructor.
 
+
 An algebraic data type M.T is "recursive" iff
         it has just one constructor, and
         (a) it is declared in an hi-boot file (see RdrHsSyn.hsIfaceDecl)
@@ -232,9 +271,18 @@ calcRecFlags boot_details tyclss
         -- loop.  We could program round this, but it'd make the code
         -- rather less nice, so I'm not going to do that yet.
 
+    single_con_tycons = filter (isSingleton . tyConDataCons) all_tycons
+        -- Both newtypes and data types, with exactly one data constructor
+    (new_tycons, prod_tycons) = partition isNewTyCon single_con_tycons
+        -- NB: we do *not* call isProductTyCon because that checks
+       --     for vanilla-ness of data constructors; and that depends
+       --     on empty existential type variables; and that is figured
+       --     out by tcResultType; which uses tcMatchTy; which uses
+       --     coreView; which calls coreExpandTyCon_maybe; which uses
+       --     the recursiveness of the TyCon.  Result... a black hole.
+       -- YUK YUK YUK
+
         --------------- Newtypes ----------------------
-    new_tycons = filter isNewTyConAndNotOpen all_tycons
-    isNewTyConAndNotOpen tycon = isNewTyCon tycon && not (isOpenTyCon tycon)
     nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges)
     is_rec_nt tc = tyConName tc  `elemNameSet` nt_loop_breakers
         -- is_rec_nt is a locally-used helper function
@@ -252,9 +300,6 @@ calcRecFlags boot_details tyclss
         | otherwise = []
 
         --------------- Product types ----------------------
-        -- The "prod_tycons" are the non-newtype products
-    prod_tycons = [tc | tc <- all_tycons,
-                        not (isNewTyCon tc), isProductTyCon tc]
     prod_loop_breakers = mkNameSet (findLoopBreakers prod_edges)
 
     prod_edges = [(tc, mk_prod_edges tc) | tc <- prod_tycons]
@@ -287,7 +332,7 @@ findLoopBreakers deps
   = go [(tc,tc,ds) | (tc,ds) <- deps]
   where
     go edges = [ name
-               | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompR edges,
+               | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompFromEdgedVerticesR edges,
                  name <- tyConName tc : go edges']
 \end{code}