X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcTyDecls.lhs;h=3ceeb8ea7e949c7b6db911cbab12092013ea3249;hb=8254dcf1884fde961c477d5784024ec8ab1d84d2;hp=e67cabe487145ebb8723367613bf3a3215cad8a0;hpb=98688c6e8fd33f31c51218cf93cbf03fe3a5e73d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index e67cabe..3ceeb8e 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -12,32 +12,31 @@ files for imported data types. \begin{code} module TcTyDecls( - calcTyConArgVrcs, tyVarVrc, - calcRecFlags, calcCycleErrs, - newTyConRhs + calcTyConArgVrcs, + calcRecFlags, + calcClassCycles, calcSynCycles ) where #include "HsVersions.h" import TypeRep ( Type(..), TyNote(..), PredType(..) ) -- friend -import HsSyn ( TyClDecl(..), HsPred(..) ) +import HsSyn ( TyClDecl(..), HsPred(..), LTyClDecl, isClassDecl ) import RnHsSyn ( extractHsTyNames ) import Type ( predTypeRep ) -import BuildTyCl ( newTyConRhs ) import HscTypes ( TyThing(..) ) -import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons_maybe, tyConDataCons, tyConTyVars, +import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars, getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon, - tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs ) + tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs, newTyConRhs ) import Class ( classTyCon ) -import DataCon ( dataConRepArgTys, dataConOrigArgTys ) +import DataCon ( dataConOrigArgTys ) import Var ( TyVar ) import VarSet import Name ( Name, isTyVarName ) import NameEnv import NameSet import Digraph ( SCC(..), stronglyConnComp, stronglyConnCompR ) -import Maybe ( isNothing ) import BasicTypes ( RecFlag(..) ) +import SrcLoc ( Located(..), unLoc ) import Outputable \end{code} @@ -48,6 +47,13 @@ import Outputable %* * %************************************************************************ +Checking for class-decl loops is easy, because we don't allow class decls +in interface files. + +We allow type synonyms in hi-boot files, but we *trust* hi-boot files, +so we don't check for loops that involve them. So we only look for synonym +loops in the module being compiled. + We check for type synonym and class cycles on the *source* code. Main reasons: @@ -65,8 +71,9 @@ Main reasons: The main disadvantage is that a cycle that goes via a type synonym in an .hi-boot file can lead the compiler into a loop, because it assumes that cycles -only occur in source code. But hi-boot files are trusted anyway, so this isn't -much worse than (say) a kind error. +only occur entirely within the source code of the module being compiled. +But hi-boot files are trusted anyway, so this isn't much worse than (say) +a kind error. [ NOTE ---------------------------------------------- If we reverse this decision, this comment came from tcTyDecl1, and should @@ -88,7 +95,6 @@ synTyConsOfType ty go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim go (TyVarTy v) = emptyNameEnv go (TyConApp tc tys) = go_tc tc tys -- See note (a) - go (NewTcApp tc tys) = go_s tys -- Ignore tycon go (AppTy a b) = go a `plusNameEnv` go b go (FunTy a b) = go a `plusNameEnv` go b go (PredTy (IParam _ ty)) = go ty @@ -107,18 +113,27 @@ synTyConsOfType ty ---------------------------------------- END NOTE ] \begin{code} -calcCycleErrs :: [TyClDecl Name] -> ([[Name]], -- Recursive type synonym groups - [[Name]]) -- Ditto classes -calcCycleErrs decls - = (findCyclics syn_edges, findCyclics cls_edges) +calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)] +calcSynCycles decls + = stronglyConnComp syn_edges where - --------------- Type synonyms ---------------------- - syn_edges = [ (name, mk_syn_edges rhs) | TySynonym { tcdName = name, tcdSynRhs = rhs } <- decls ] - mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs), not (isTyVarName tc) ] + syn_edges = [ (ldecl, unLoc (tcdLName decl), + mk_syn_edges (tcdSynRhs decl)) + | ldecl@(L _ decl) <- decls ] + + mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs), + not (isTyVarName tc) ] + - --------------- Classes ---------------------- - cls_edges = [ (name, mk_cls_edges ctxt) | ClassDecl { tcdName = name, tcdCtxt = ctxt } <- decls ] - mk_cls_edges ctxt = [ cls | HsClassP cls _ <- ctxt ] +calcClassCycles :: [LTyClDecl Name] -> [[LTyClDecl Name]] +calcClassCycles decls + = [decls | CyclicSCC decls <- stronglyConnComp cls_edges] + where + cls_edges = [ (ldecl, unLoc (tcdLName decl), + mk_cls_edges (unLoc (tcdCtxt decl))) + | ldecl@(L _ decl) <- decls, isClassDecl decl ] + + mk_cls_edges ctxt = [ cls | L _ (HsClassP cls _) <- ctxt ] \end{code} @@ -128,23 +143,43 @@ calcCycleErrs decls %* * %************************************************************************ +For newtypes, we label some as "recursive" such that + + INVARIANT: there is no cycle of non-recursive newtypes + +In any loop, only one newtype need be marked as recursive; it is +a "loop breaker". Labelling more than necessary as recursive is OK, +provided the invariant is maintained. + A newtype M.T is defined to be "recursive" iff - (a) its rhs mentions an abstract (hi-boot) TyCon - or (b) one can get from T's rhs to T via type + (a) it is declared in an hi-boot file (see RdrHsSyn.hsIfaceDecl) + (b) it is declared in a source file, but that source file has a + companion hi-boot file which declares the type + or (c) one can get from T's rhs to T via type synonyms, or non-recursive newtypes *in M* - e.g. newtype T = MkT (T -> Int) + e.g. newtype T = MkT (T -> Int) -(a) is conservative; it assumes that the hi-boot type can loop - around to T. That's why in (b) we can restrict attention +(a) is conservative; declarations in hi-boot files are always + made loop breakers. That's why in (b) we can restrict attention to tycons in M, because any loops through newtypes outside M will be broken by those newtypes +(b) ensures that a newtype is not treated as a loop breaker in one place +and later as a non-loop-breaker. This matters in GHCi particularly, when +a newtype T might be embedded in many types in the environment, and then +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) its arg types mention an abstract (hi-boot) TyCon - or (b) one can get from its arg types to T via type synonyms, + (a) it is declared in an hi-boot file (see RdrHsSyn.hsIfaceDecl) + (b) it is declared in a source file, but that source file has a + companion hi-boot file which declares the type + or (c) one can get from its arg types to T via type synonyms, or by non-recursive newtypes or non-recursive product types in M - e.g. data T = MkT (T -> Int) Bool + e.g. data T = MkT (T -> Int) Bool +Just like newtype in fact A type synonym is recursive if one can get from its right hand side back to it via type synonyms. (This is @@ -155,7 +190,7 @@ back to it. (This is an error too.) Hi-boot types ~~~~~~~~~~~~~ -A data type read from an hi-boot file will have an Unknown in its data constructors, +A data type read from an hi-boot file will have an AbstractTyCon as its AlgTyConRhs and will respond True to isHiBootTyCon. The idea is that we treat these as if one could get from these types to anywhere. So when we see @@ -178,17 +213,27 @@ recursiveness, because we need only look at the type decls in the module being compiled, plus the outer structure of directly-mentioned types. \begin{code} -calcRecFlags :: [TyThing] -> (Name -> RecFlag) -calcRecFlags tyclss +calcRecFlags :: [Name] -> [TyThing] -> (Name -> RecFlag) +-- The 'boot_names' are the things declared in M.hi-boot, if M is the current module. +-- Any type constructors in boot_names are automatically considered loop breakers +calcRecFlags boot_names tyclss = is_rec where is_rec n | n `elemNameSet` rec_names = Recursive | otherwise = NonRecursive - rec_names = nt_loop_breakers `unionNameSets` prod_loop_breakers + boot_name_set = mkNameSet boot_names + rec_names = boot_name_set `unionNameSets` + nt_loop_breakers `unionNameSets` + prod_loop_breakers - all_tycons = map getTyCon tyclss -- Recursion of newtypes/data types - -- can happen via the class TyCon + all_tycons = [ tc | tycls <- 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) ] + -- Remove the boot_name_set because they are going + -- to be loop breakers regardless. ------------------------------------------------- -- NOTE @@ -209,15 +254,13 @@ calcRecFlags tyclss nt_edges = [(t, mk_nt_edges t) | t <- new_tycons] mk_nt_edges nt -- Invariant: nt is a newtype - = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (newTyConRhs nt)) + = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (new_tc_rhs nt)) -- tyConsOfType looks through synonyms mk_nt_edges1 nt tc | tc `elem` new_tycons = [tc] -- Loop - | isHiBootTyCon tc = [nt] -- Make it self-recursive if - -- it mentions an hi-boot TyCon - -- 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 cycle + -- 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 ---------------------- @@ -237,13 +280,13 @@ calcRecFlags tyclss | tc `elem` prod_tycons = [tc] -- Local product | tc `elem` new_tycons = if is_rec_nt tc -- Local newtype then [] - else mk_prod_edges1 ptc (newTyConRhs tc) - | isHiBootTyCon tc = [ptc] -- Make it self-recursive if - -- it mentions an hi-boot TyCon + else mk_prod_edges1 ptc (new_tc_rhs tc) -- At this point we know that either it's a local non-product data type, -- or it's imported. Either way, it can't form part of a cycle | otherwise = [] +new_tc_rhs tc = snd (newTyConRhs tc) -- Ignore the type variables + getTyCon (ATyCon tc) = tc getTyCon (AClass cl) = classTyCon cl @@ -255,12 +298,6 @@ findLoopBreakers deps go edges = [ name | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompR edges, name <- tyConName tc : go edges'] - -findCyclics :: [(Name,[Name])] -> [[Name]] -findCyclics deps - = [names | CyclicSCC names <- stronglyConnComp edges] - where - edges = [(name,name,ds) | (name,ds) <- deps] \end{code} These two functions know about type representations, so they could be @@ -278,7 +315,6 @@ tcTyConsOfType ty go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim go (TyVarTy v) = emptyNameEnv go (TyConApp tc tys) = go_tc tc tys - go (NewTcApp 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 @@ -333,11 +369,7 @@ calcTyConArgVrcs tyclss initial_oi :: NameEnv (TyCon, ArgVrcs) initial_oi = mkNameEnv [(tyConName tc, (tc, initial tc)) | tc <- tycons] - initial tc = if isAlgTyCon tc && isNothing (tyConDataCons_maybe tc) then - -- make pessimistic assumption (and warn) - abstractVrcs tc - else - replicate (tyConArity tc) (False,False) + initial tc = replicate (tyConArity tc) (False,False) tcaoFix :: NameEnv (TyCon, ArgVrcs) -- initial ArgVrcs per tycon -> NameEnv (TyCon, ArgVrcs) -- fixpointed ArgVrcs per tycon @@ -358,14 +390,11 @@ calcTyConArgVrcs tyclss -> ArgVrcs -- new ArgVrcs for tycon tcaoIter oi tc | isAlgTyCon tc - = if null data_cons then - abstractVrcs tc -- Data types with no constructors - else - map (\v -> anyVrc (vrcInTy (lookup oi) v) argtys) vs + = map (\v -> anyVrc (vrcInTy (lookup oi) v) argtys) vs where data_cons = tyConDataCons tc vs = tyConTyVars tc - argtys = concatMap dataConRepArgTys data_cons -- Rep? or Orig? + argtys = concatMap dataConOrigArgTys data_cons -- Rep? or Orig? tcaoIter oi tc | isSynTyCon tc = let (tyvs,ty) = getSynTyConDefn tc @@ -376,20 +405,6 @@ calcTyConArgVrcs tyclss Just (_, pms) -> pms Nothing -> tyConArgVrcs tc -- We use the already-computed result for tycons not in this SCC - - -abstractVrcs :: TyCon -> ArgVrcs -abstractVrcs tc = -#ifdef DEBUG - pprTrace "Vrc: abstract tycon:" (ppr tc) $ -#endif - warn_abstract_vrcs `seq` replicate (tyConArity tc) (True,True) - -warn_abstract_vrcs --- we pull the message out as a CAF so the warning only appears *once* - = trace ("WARNING: tyConArgVrc info inaccurate due to unavailable constructors.\n" - ++ " Use -fno-prune-tydecls to fix.") $ - () \end{code} @@ -441,25 +456,9 @@ vrcInTy fao v (TyConApp tc tys) = let pms1 = map (vrcInTy fao v) tys pms2 = fao tc in orVrcs (zipWith timesVrc pms1 pms2) -vrcInTy fao v (NewTcApp tc tys) = let pms1 = map (vrcInTy fao v) tys - pms2 = fao tc - in orVrcs (zipWith timesVrc pms1 pms2) - vrcInTy fao v (PredTy st) = vrcInTy fao v (predTypeRep st) \end{code} - -External entry point: assumes tyconargvrcs already computed. - -\begin{code} -tyVarVrc :: TyVar -- tyvar to check Vrc of - -> Type -- type to check for occ in - -> (Bool,Bool) -- (occurs positively, occurs negatively) - -tyVarVrc = vrcInTy tyConArgVrcs -\end{code} - - Variance algebra ~~~~~~~~~~~~~~~~