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
import Digraph
import BasicTypes
import SrcLoc
-import Outputable
+import Maybes( mapCatMaybes )
+import Util ( isSingleton )
+import Data.List
\end{code}
\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))
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)))
%* *
%************************************************************************
+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
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)
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
- 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.
-- 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
= 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 ----------------------
- -- 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]
-- 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
-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
= 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}
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 (PredTy (EqPred ty1 ty2)) = go ty1 `plusNameEnv` go ty2
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
projects / ghc-hetmet.git / blobdiff