fix haddock submodule pointer

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

diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index 8b9c6f1..15c817a 100644 (file)
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -9,13 +9,6 @@ This stuff is only used for source-code decls; it's recorded in interface
 files for imported data types.
 
 \begin{code}
 files for imported data types.
 
 \begin{code}

-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-

 module TcTyDecls(
         calcRecFlags,
         calcClassCycles, calcSynCycles
 module TcTyDecls(
         calcRecFlags,
         calcClassCycles, calcSynCycles

@@ -37,7 +30,9 @@ import NameSet
 import Digraph
 import BasicTypes
 import SrcLoc
 import Digraph
 import BasicTypes
 import SrcLoc

-import Outputable
+import Maybes( mapCatMaybes )
+import Util ( isSingleton )
+import Data.List

 \end{code}
 
 
 \end{code}
 
 

@@ -109,7 +104,7 @@ synTyConsOfType ty
 \begin{code}
 calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
 calcSynCycles decls
 \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))
   where
     syn_edges = [ (ldecl, unLoc (tcdLName decl),
                           mk_syn_edges (tcdSynRhs decl))

@@ -121,7 +116,7 @@ calcSynCycles decls
 
 calcClassCycles :: [LTyClDecl Name] -> [[LTyClDecl Name]]
 calcClassCycles 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)))
   where
     cls_edges = [ (ldecl, unLoc (tcdLName decl),
                           mk_cls_edges (unLoc (tcdCtxt decl)))

@@ -137,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
 For newtypes, we label some as "recursive" such that
 
     INVARIANT: there is no cycle of non-recursive newtypes

@@ -165,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.
 
 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)
 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)

@@ -221,11 +253,10 @@ calcRecFlags boot_details tyclss
                 nt_loop_breakers  `unionNameSets`
                 prod_loop_breakers
 
                 nt_loop_breakers  `unionNameSets`
                 prod_loop_breakers
 

-    all_tycons = [ tc | tycls <- tyclss,
+    all_tycons = [ tc | tc <- mapCatMaybes getTyCon tyclss

                            -- Recursion of newtypes/data types can happen via
                            -- the class TyCon, so tyclss includes the class tycons
                            -- Recursion of newtypes/data types can happen via
                            -- the class TyCon, so tyclss includes the class tycons

-                        let tc = getTyCon tycls,
-                        not (tyConName tc `elemNameSet` boot_name_set) ]
+                      , not (tyConName tc `elemNameSet` boot_name_set) ]

                            -- Remove the boot_name_set because they are going
                            -- to be loop breakers regardless.
 
                            -- Remove the boot_name_set because they are going
                            -- to be loop breakers regardless.
 

@@ -239,9 +270,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,16 +292,13 @@ calcRecFlags boot_details tyclss
         = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (new_tc_rhs nt))
                         -- tyConsOfType looks through synonyms
 
         = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (new_tc_rhs nt))
                         -- tyConsOfType looks through synonyms
 

-    mk_nt_edges1 nt tc
+    mk_nt_edges1 _ tc

         | tc `elem` new_tycons = [tc]           -- Loop
                 -- At this point we know that either it's a local *data* type,
                 -- or it's imported.  Either way, it can't form part of a newtype cycle
         | otherwise = []
 
         --------------- Product types ----------------------
         | tc `elem` new_tycons = [tc]           -- Loop
                 -- At this point we know that either it's a local *data* type,
                 -- or it's imported.  Either way, it can't form part of a newtype cycle
         | 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]

@@ -280,11 +317,13 @@ calcRecFlags boot_details tyclss
                 -- or it's imported.  Either way, it can't form part of a cycle
         | otherwise = []
 
                 -- or it's imported.  Either way, it can't form part of a cycle
         | otherwise = []
 

+new_tc_rhs :: TyCon -> Type

 new_tc_rhs tc = snd (newTyConRhs tc)    -- Ignore the type variables
 
 new_tc_rhs tc = snd (newTyConRhs tc)    -- Ignore the type variables
 

-getTyCon (ATyCon tc) = tc
-getTyCon (AClass cl) = classTyCon cl
-getTyCon other       = panic "getTyCon"
+getTyCon :: TyThing -> Maybe TyCon
+getTyCon (ATyCon tc) = Just tc
+getTyCon (AClass cl) = Just (classTyCon cl)
+getTyCon _           = Nothing

 
 findLoopBreakers :: [(TyCon, [TyCon])] -> [Name]
 -- Finds a set of tycons that cut all loops
 
 findLoopBreakers :: [(TyCon, [TyCon])] -> [Name]
 -- Finds a set of tycons that cut all loops

@@ -292,7 +331,7 @@ findLoopBreakers deps
   = go [(tc,tc,ds) | (tc,ds) <- deps]
   where
     go edges = [ name
   = 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}
 
                  name <- tyConName tc : go edges']
 \end{code}
 

@@ -310,14 +349,14 @@ tcTyConsOfType ty
   where
      go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim
      go ty | Just ty' <- tcView ty = go ty'
   where
      go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim
      go ty | Just ty' <- tcView ty = go ty'

-     go (TyVarTy v)                = emptyNameEnv
+     go (TyVarTy _)                = emptyNameEnv

      go (TyConApp tc tys)          = go_tc tc tys
      go (AppTy a b)                = go a `plusNameEnv` go b
      go (FunTy a b)                = go a `plusNameEnv` go b
      go (PredTy (IParam _ ty))     = go ty
      go (PredTy (ClassP cls tys))  = go_tc (classTyCon cls) tys
      go (TyConApp tc tys)          = go_tc tc tys
      go (AppTy a b)                = go a `plusNameEnv` go b
      go (FunTy a b)                = go a `plusNameEnv` go b
      go (PredTy (IParam _ ty))     = go ty
      go (PredTy (ClassP cls tys))  = go_tc (classTyCon cls) tys

+     go (PredTy (EqPred ty1 ty2))  = go ty1 `plusNameEnv` go ty2

      go (ForAllTy _ ty)            = go ty
      go (ForAllTy _ ty)            = go ty

-     go other                      = panic "tcTyConsOfType"

 
      go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
      go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
 
      go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
      go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys