Fix an nasty black hole, concerning computation of isRecursiveTyCon

Fixing #246 (pattern-match order in record patterns) made GHC go into
a black hole, by changing the order of patterm matching in
TyCon.isProductTyCon!  It turned out that GHC had been avoiding the
black hole only by the narrowest of margins up to now!

The black hole concerned the computation of which type constructors
are recursive, in TcTyDecls.calcRecFlags.  We now refrain from using
isProductTyCon there, since it triggers the black hole (very
indirectly).  See the "YUK YUK" comment in the body of calcRecFlags.

As it turns out, the fact that TyCon.isProductTyCon matched on the
algTcRec field was quite redundant, so I removed that too.  However,
without the fix to calcRecFlags, this wouldn't fix the black hole
because of the use of isRecursiveTyCon in BuildTyCl.mkNewTyConRhs.

Anyway, it's fine now.

diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index e39b870..9b0e681 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 BasicTypes
 import SrcLoc
 import Outputable

+import Util ( isSingleton )
+import List ( partition )

 \end{code}
 
 
 \end{code}
 
 

@@ -232,9 +234,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.
 
         -- 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 ----------------------
         --------------- 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
     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 +263,6 @@ calcRecFlags boot_details tyclss
         | otherwise = []
 
         --------------- Product types ----------------------
         | 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]
     prod_loop_breakers = mkNameSet (findLoopBreakers prod_edges)
 
     prod_edges = [(tc, mk_prod_edges tc) | tc <- prod_tycons]

diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 2965f6c..dc7e2d3 100644 (file)
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -954,7 +954,7 @@ tcExpandTyCon_maybe _ _ = Nothing
 
 -- ^ Used to create the view /Core/ has on 'TyCon's. We expand not only closed synonyms like 'tcExpandTyCon_maybe',
 -- but also non-recursive @newtype@s
 
 -- ^ Used to create the view /Core/ has on 'TyCon's. We expand not only closed synonyms like 'tcExpandTyCon_maybe',
 -- but also non-recursive @newtype@s

-coreExpandTyCon_maybe (AlgTyCon {algTcRec = NonRecursive,      -- Not recursive
+coreExpandTyCon_maybe (AlgTyCon {

          algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs, nt_co = Nothing }}) tys
    = case etad_rhs of  -- Don't do this in the pattern match, lest we accidentally
                        -- match the etad_rhs of a *recursive* newtype
          algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs, nt_co = Nothing }}) tys
    = case etad_rhs of  -- Don't do this in the pattern match, lest we accidentally
                        -- match the etad_rhs of a *recursive* newtype