X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyDecls.lhs;h=a9ea11aefa19ab6158959342eabfffdd92f90318;hp=11b9c3bc9599b17199aeb805736feb04b6dfeda5;hb=6ea06bbf08517d9805feb82df65cc56ecbaf23a4;hpb=6bc54d1524cd6d10a978bef89bc6a8f0061adb66

diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index 11b9c3b..a9ea11a 100644
--- 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}