From: simonpj@microsoft.com Date: Mon, 10 Jan 2011 11:03:51 +0000 (+0000) Subject: Do dependency analysis when kind-checking type declarations X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=6ea06bbf08517d9805feb82df65cc56ecbaf23a4 Do dependency analysis when kind-checking type declarations This patch fixes Trac #4875. The main point is to do dependency analysis on type and class declarations, and kind-check them in dependency order, so as to improve error messages. This patch means that a few programs that would typecheck before won't typecheck any more; but before we were (naughtily) going beyond Haskell 98 without any language-extension flags, and Trac #4875 convinces me that doing so is a Bad Idea. Here's an example that won't typecheck any more data T a b = MkT (a b) type F k = T k Maybe If you look at T on its own you'd default 'a' to kind *->*; and then kind-checking would fail on F. But GHC currently accepts this program beause it looks at the *occurrences* of T. --- diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 7d70ad8..5da376b 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -119,7 +119,7 @@ repTopDs group decls <- addBinds ss (do { val_ds <- rep_val_binds (hs_valds group) ; - tycl_ds <- mapM repTyClD (hs_tyclds group) ; + tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ; inst_ds <- mapM repInstD' (hs_instds group) ; for_ds <- mapM repForD (hs_fords group) ; -- more needed diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index fd6d3bb..8827f3a 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -126,7 +126,12 @@ data HsDecl id data HsGroup id = HsGroup { hs_valds :: HsValBinds id, - hs_tyclds :: [LTyClDecl id], + + hs_tyclds :: [[LTyClDecl id]], + -- A list of mutually-recursive groups + -- Parser generates a singleton list; + -- renamer does dependency analysis + hs_instds :: [LInstDecl id], hs_derivds :: [LDerivDecl id], @@ -228,7 +233,8 @@ instance OutputableBndr name => Outputable (HsGroup name) where if isEmptyValBinds val_decls then Nothing else Just (ppr val_decls), - ppr_ds tycl_decls, ppr_ds inst_decls, + ppr_ds (concat tycl_decls), + ppr_ds inst_decls, ppr_ds deriv_decls, ppr_ds foreign_decls] where diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index d17f850..3ef4bff 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -60,7 +60,7 @@ module HsUtils( collectLStmtBinders, collectStmtBinders, collectSigTysFromPats, collectSigTysFromPat, - hsTyClDeclBinders, hsTyClDeclsBinders, hsConDeclsBinders, + hsTyClDeclBinders, hsTyClDeclsBinders, hsForeignDeclsBinders, hsGroupBinders ) where @@ -572,9 +572,10 @@ hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name] hsForeignDeclsBinders foreign_decls = [n | L _ (ForeignImport (L _ n) _ _) <- foreign_decls] -hsTyClDeclsBinders :: [Located (TyClDecl Name)] -> [Located (InstDecl Name)] -> [Name] +hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name] hsTyClDeclsBinders tycl_decls inst_decls - = [n | d <- instDeclATs inst_decls ++ tycl_decls, L _ n <- hsTyClDeclBinders d] + = [n | d <- instDeclATs inst_decls ++ concat tycl_decls + , L _ n <- hsTyClDeclBinders d] hsTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name] -- ^ Returns all the /binding/ names of the decl, along with their SrcLocs. diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 5524e2d..a756c7f 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -446,7 +446,7 @@ get_local_binders gbl_env (HsGroup {hs_valds = ValBindsIn _ val_sigs, hs_fords = foreign_decls }) = do { -- separate out the family instance declarations let (tyinst_decls1, tycl_decls_noinsts) - = partition (isFamInstDecl . unLoc) tycl_decls + = partition (isFamInstDecl . unLoc) (concat tycl_decls) tyinst_decls = tyinst_decls1 ++ instDeclATs inst_decls -- process all type/class decls except family instances diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 3766e21..2ce2170 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -50,9 +50,10 @@ import DynFlags import HscTypes ( HscEnv, hsc_dflags ) import BasicTypes ( Boxity(..) ) import ListSetOps ( findDupsEq ) - +import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices ) import Control.Monad +import Maybes( orElse ) import Data.Maybe \end{code} @@ -146,7 +147,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- means we'll only report a declaration as unused if it isn't -- mentioned at all. Ah well. traceRn (text "Start rnTyClDecls") ; - (rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ; + (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ; -- (F) Rename Value declarations right-hand sides traceRn (text "Start rnmono") ; @@ -218,11 +219,6 @@ inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a inNewEnv env cont = do e <- env setGblEnv e $ cont e -rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name] --- Used for external core -rnTyClDecls tycl_decls = do (decls', _fvs) <- rnList rnTyClDecl tycl_decls - return decls' - addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv -- This function could be defined lower down in the module hierarchy, -- but there doesn't seem anywhere very logical to put it. @@ -681,6 +677,18 @@ and then go over it again to rename the tyvars! However, we can also do some scoping checks at the same time. \begin{code} +rnTyClDecls :: [[LTyClDecl RdrName]] -> RnM ([[LTyClDecl Name]], FreeVars) +-- Renamed the declarations and do depedency analysis on them +rnTyClDecls tycl_ds + = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (concat tycl_ds) + + ; let sccs :: [SCC (LTyClDecl Name)] + sccs = depAnalTyClDecls ds_w_fvs + + all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs + + ; return (map flattenSCC sccs, all_fvs) } + rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars) rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name}) = lookupLocatedTopBndrRn name `thenM` \ name' -> @@ -832,6 +840,35 @@ to cause programs to break unnecessarily (notably HList). So if there are no data constructors we allow h98_style = True +\begin{code} +depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)] +-- See Note [Dependency analysis of type and class decls] +depAnalTyClDecls ds_w_fvs + = stronglyConnCompFromEdgedVertices edges + where + edges = [ (d, tcdName (unLoc d), map get_assoc (nameSetToList fvs)) + | (d, fvs) <- ds_w_fvs ] + get_assoc n = lookupNameEnv assoc_env n `orElse` n + assoc_env = mkNameEnv [ (tcdName assoc_decl, cls_name) + | (L _ (ClassDecl { tcdLName = L _ cls_name + , tcdATs = ats }) ,_) <- ds_w_fvs + , L _ assoc_decl <- ats ] +\end{code} + +Note [Dependency analysis of type and class decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to do dependency analysis on type and class declarations +else we get bad error messages. Consider + + data T f a = MkT f a + data S f a = MkS f (T f a) + +This has a kind error, but the error message is better if you +check T first, (fixing its kind) and *then* S. If you do kind +inference together, you might get an error reported in S, which +is jolly confusing. See Trac #4875 + + %********************************************************* %* * \subsection{Support code for type/data declarations} @@ -1041,7 +1078,7 @@ badDataCon name Get the mapping from constructors to fields for this module. It's convenient to do this after the data type decls have been renamed \begin{code} -extendRecordFieldEnv :: [LTyClDecl RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv +extendRecordFieldEnv :: [[LTyClDecl RdrName]] -> [LInstDecl RdrName] -> TcM TcGblEnv extendRecordFieldEnv tycl_decls inst_decls = do { tcg_env <- getGblEnv ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons @@ -1059,7 +1096,7 @@ extendRecordFieldEnv tycl_decls inst_decls all_data_cons :: [ConDecl RdrName] all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls , L _ con <- cons ] - all_tycl_decls = at_tycl_decls ++ tycl_decls + all_tycl_decls = at_tycl_decls ++ concat tycl_decls at_tycl_decls = instDeclATs inst_decls -- Do not forget associated types! get_con (ConDecl { con_name = con, con_details = RecCon flds }) @@ -1148,9 +1185,9 @@ add gp _ (QuasiQuoteD qq) ds -- Expand quasiquotes add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds | isClassDecl d = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in - addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds + addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds | otherwise - = addl (gp { hs_tyclds = L l d : ts }) ds + = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds -- Signatures: fixity sigs go a different place than all others add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds @@ -1180,6 +1217,10 @@ add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds add gp l (DocD d) ds = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds +add_tycld :: LTyClDecl a -> [[LTyClDecl a]] -> [[LTyClDecl a]] +add_tycld d [] = [[d]] +add_tycld d (ds:dss) = (d:ds) : dss + add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind" diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index f84f3d5..1979c8d 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -371,7 +371,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls ; let { (local_info, at_tycons_s) = unzip local_info_tycons ; at_idx_tycons = concat at_tycons_s ++ idx_tycons - ; clas_decls = filter (isClassDecl.unLoc) tycl_decls + ; clas_decls = filter (isClassDecl . unLoc) tycl_decls ; implicit_things = concatMap implicitTyThings at_idx_tycons ; aux_binds = mkRecSelBinds at_idx_tycons } diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 893365e..773f307 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -290,7 +290,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) setEnvs tc_envs $ do { - rn_decls <- checkNoErrs $ rnTyClDecls ldecls ; + (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [ldecls] ; -- Dump trace of renaming part rnDump (ppr rn_decls) ; @@ -348,7 +348,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mkFakeGroup :: [LTyClDecl a] -> HsGroup a mkFakeGroup decls -- Rather clumsy; lots of unused fields - = emptyRdrGroup { hs_tyclds = decls } + = emptyRdrGroup { hs_tyclds = [decls] } \end{code} @@ -504,7 +504,7 @@ tcRnHsBootDecls decls -- Family instance declarations are rejected here ; traceTc "Tc3" empty ; (tcg_env, inst_infos, _deriv_binds) - <- tcInstDecls1 tycl_decls inst_decls deriv_decls + <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls ; setGblEnv tcg_env $ do { -- Typecheck value declarations @@ -846,7 +846,7 @@ tcTopSrcDecls boot_details -- and import the supporting declarations traceTc "Tc3" empty ; (tcg_env, inst_infos, deriv_binds) - <- tcInstDecls1 tycl_decls inst_decls deriv_decls; + <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls; setGblEnv tcg_env $ do { -- Foreign import declarations next. @@ -875,7 +875,7 @@ tcTopSrcDecls boot_details -- Second pass over class and instance declarations, traceTc "Tc6" empty ; - inst_binds <- tcInstDecls2 tycl_decls inst_infos ; + inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ; -- Foreign exports traceTc "Tc7" empty ; diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 1658e0b..a433d69 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -60,180 +60,78 @@ import Data.List %* * %************************************************************************ -Dealing with a group -~~~~~~~~~~~~~~~~~~~~ -Consider a mutually-recursive group, binding -a type constructor T and a class C. - -Step 1: getInitialKind - Construct a KindEnv by binding T and C to a kind variable - -Step 2: kcTyClDecl - In that environment, do a kind check - -Step 3: Zonk the kinds - -Step 4: buildTyConOrClass - Construct an environment binding T to a TyCon and C to a Class. - a) Their kinds comes from zonking the relevant kind variable - b) Their arity (for synonyms) comes direct from the decl - c) The funcional dependencies come from the decl - d) The rest comes a knot-tied binding of T and C, returned from Step 4 - e) The variances of the tycons in the group is calculated from - the knot-tied stuff - -Step 5: tcTyClDecl1 - In this environment, walk over the decls, constructing the TyCons and Classes. - This uses in a strict way items (a)-(c) above, which is why they must - be constructed in Step 4. Feed the results back to Step 4. - For this step, pass the is-recursive flag as the wimp-out flag - to tcTyClDecl1. - - -Step 6: Extend environment - We extend the type environment with bindings not only for the TyCons and Classes, - but also for their "implicit Ids" like data constructors and class selectors - -Step 7: checkValidTyCl - For a recursive group only, check all the decls again, just - to check all the side conditions on validity. We could not - do this before because we were in a mutually recursive knot. - -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. - \begin{code} -tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name] +tcTyAndClassDecls :: ModDetails + -> [[LTyClDecl Name]] -- Mutually-recursive groups in dependency order -> TcM (TcGblEnv, -- Input env extended by types and classes -- and their implicit Ids,DataCons HsValBinds Name, -- Renamed bindings for record selectors [Id]) -- Default method ids - -- Fails if there are any errors -tcTyAndClassDecls boot_details allDecls +tcTyAndClassDecls boot_details decls_s = checkNoErrs $ -- The code recovers internally, but if anything gave rise to -- an error we'd better stop now, to avoid a cascade - do { -- Omit instances of type families; they are handled together - -- with the *heads* of class instances - ; let decls = filter (not . isFamInstDecl . unLoc) allDecls - - -- First check for cyclic type synonysm or classes - -- See notes with checkCycleErrs - ; checkCycleErrs decls - ; mod <- getModule - ; traceTc "tcTyAndCl" (ppr mod) - ; (syn_tycons, alg_tyclss) <- fixM (\ ~(_rec_syn_tycons, rec_alg_tyclss) -> - do { let { -- Seperate ordinary synonyms from all other type and - -- class declarations and add all associated type - -- declarations from type classes. The latter is - -- required so that the temporary environment for the - -- knot includes all associated family declarations. - ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) - decls - ; alg_at_decls = concatMap addATs alg_decls - } - -- Extend the global env with the knot-tied results - -- for data types and classes - -- - -- We must populate the environment with the loop-tied - -- T's right away, because the kind checker may "fault - -- in" some type constructors that recursively - -- mention T - ; let gbl_things = mkGlobalThings alg_at_decls rec_alg_tyclss - ; tcExtendRecEnv gbl_things $ do - - -- Kind-check the declarations - { (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls - - ; let { -- Calculate rec-flag - ; calc_rec = calcRecFlags boot_details rec_alg_tyclss - ; tc_decl = addLocM (tcTyClDecl calc_rec) } - - -- Type-check the type synonyms, and extend the envt - ; syn_tycons <- tcSynDecls kc_syn_decls - ; tcExtendGlobalEnv syn_tycons $ do - - -- Type-check the data types and classes - { alg_tyclss <- mapM tc_decl kc_alg_decls - ; return (syn_tycons, concat alg_tyclss) - }}}) - -- Finished with knot-tying now - -- Extend the environment with the finished things - ; tcExtendGlobalEnv (syn_tycons ++ alg_tyclss) $ do - - -- Perform the validity check - { traceTc "ready for validity check" empty - ; mapM_ (addLocM checkValidTyCl) decls + do { let tyclds_s = map (filterOut (isFamInstDecl . unLoc)) decls_s + -- Remove family instance decls altogether + -- They are dealt with by TcInstDcls + + ; tyclss <- fixM $ \ rec_tyclss -> + tcExtendRecEnv (zipRecTyClss tyclds_s rec_tyclss) $ + -- We must populate the environment with the loop-tied + -- T's right away (even before kind checking), because + -- the kind checker may "fault in" some type constructors + -- that recursively mention T + + do { -- Kind-check in dependency order + -- See Note [Kind checking for type and class decls] + kc_decls <- kcTyClDecls tyclds_s + + -- And now build the TyCons/Classes + ; let rec_flags = calcRecFlags boot_details rec_tyclss + ; concatMapM (tcTyClDecl rec_flags) kc_decls } + + ; tcExtendGlobalEnv tyclss $ do + { -- Perform the validity check + -- We can do this now because we are done with the recursive knot + traceTc "ready for validity check" empty + ; mapM_ (addLocM checkValidTyCl) (concat tyclds_s) ; traceTc "done" empty - + -- Add the implicit things; - -- we want them in the environment because + -- we want them in the environment because -- they may be mentioned in interface files -- NB: All associated types and their implicit things will be added a -- second time here. This doesn't matter as the definitions are -- the same. - ; let { implicit_things = concatMap implicitTyThings alg_tyclss - ; rec_sel_binds = mkRecSelBinds alg_tyclss - ; dm_ids = mkDefaultMethodIds alg_tyclss } - ; traceTc "Adding types and classes" $ vcat - [ ppr alg_tyclss - , text "and" <+> ppr implicit_things ] + ; let { implicit_things = concatMap implicitTyThings tyclss + ; rec_sel_binds = mkRecSelBinds tyclss + ; dm_ids = mkDefaultMethodIds tyclss } + ; env <- tcExtendGlobalEnv implicit_things getGblEnv - ; return (env, rec_sel_binds, dm_ids) } - } - where - -- Pull associated types out of class declarations, to tie them into the - -- knot above. - -- NB: We put them in the same place in the list as `tcTyClDecl' will - -- eventually put the matching `TyThing's. That's crucial; otherwise, - -- the two argument lists of `mkGlobalThings' don't match up. - addATs decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats - addATs decl = [decl] - -mkGlobalThings :: [LTyClDecl Name] -- The decls - -> [TyThing] -- Knot-tied, in 1-1 correspondence with the decls - -> [(Name,TyThing)] --- Driven by the Decls, and treating the TyThings lazily --- make a TypeEnv for the new things -mkGlobalThings decls things - = map mk_thing (decls `zipLazy` things) + ; return (env, rec_sel_binds, dm_ids) } } + +zipRecTyClss :: [[LTyClDecl Name]] + -> [TyThing] -- Knot-tied + -> [(Name,TyThing)] +-- Build a name-TyThing mapping for the things bound by decls +-- being careful not to look at the [TyThing] +-- The TyThings in the result list must have a visible ATyCon/AClass, +-- because typechecking types (in, say, tcTyClDecl) looks at this outer constructor +zipRecTyClss decls_s rec_things + = [ get decl | decls <- decls_s, L _ decl <- flattenATs decls ] where - mk_thing (L _ (ClassDecl {tcdLName = L _ name}), ~(AClass cl)) - = (name, AClass cl) - mk_thing (L _ decl, ~(ATyCon tc)) - = (tcdName decl, ATyCon tc) + rec_type_env :: TypeEnv + rec_type_env = mkTypeEnv rec_things + + get :: TyClDecl Name -> (Name, TyThing) + get (ClassDecl {tcdLName = L _ name}) = (name, AClass cl) + where + Just (AClass cl) = lookupTypeEnv rec_type_env name + get decl = (name, ATyCon tc) + where + name = tcdName decl + Just (ATyCon tc) = lookupTypeEnv rec_type_env name \end{code} @@ -425,6 +323,25 @@ kcIdxTyPats decl thing_inside %* * %************************************************************************ +Note [Kind checking for type and class decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Kind checking is done thus: + + 1. Make up a kind variable for each parameter of the *data* type, + and class, decls, and extend the kind environment (which is in + the TcLclEnv) + + 2. Dependency-analyse the type *synonyms* (which must be non-recursive), + and kind-check them in dependency order. Extend the kind envt. + + 3. Kind check the data type and class decls + +Synonyms are treated differently to data type and classes, +because a type synonym can be an unboxed type + type Foo = Int# +and a kind variable can't unify with UnboxedTypeKind +So we infer their kinds in dependency order + We need to kind check all types in the mutually recursive group before we know the kind of the type variables. For example: @@ -459,48 +376,52 @@ instances of families altogether in the following. However, we need to include the kinds of associated families into the construction of the initial kind environment. (This is handled by `allDecls'). + \begin{code} -kcTyClDecls :: [LTyClDecl Name] -> [Located (TyClDecl Name)] - -> TcM ([LTyClDecl Name], [Located (TyClDecl Name)]) -kcTyClDecls syn_decls alg_decls - = do { -- First extend the kind env with each data type, class, and - -- indexed type, mapping them to a type variable - let initialKindDecls = concat [allDecls decl | L _ decl <- alg_decls] - ; alg_kinds <- mapM getInitialKind initialKindDecls - ; tcExtendKindEnv alg_kinds $ do - - -- Now kind-check the type synonyms, in dependency order - -- We do these differently to data type and classes, - -- because a type synonym can be an unboxed type - -- type Foo = Int# - -- and a kind variable can't unify with UnboxedTypeKind - -- So we infer their kinds in dependency order - { (kc_syn_decls, syn_kinds) <- kcSynDecls (calcSynCycles syn_decls) - ; tcExtendKindEnv syn_kinds $ do - - -- Now kind-check the data type, class, and kind signatures, - -- returning kind-annotated decls; we don't kind-check - -- instances of indexed types yet, but leave this to - -- `tcInstDecls1' - { kc_alg_decls <- mapM (wrapLocM kcTyClDecl) - (filter (not . isFamInstDecl . unLoc) alg_decls) - - ; return (kc_syn_decls, kc_alg_decls) }}} +kcTyClDecls :: [[LTyClDecl Name]] -> TcM [LTyClDecl Name] +kcTyClDecls [] = return [] +kcTyClDecls (decls : decls_s) = do { (tcl_env, kc_decls1) <- kcTyClDecls1 decls + ; kc_decls2 <- setLclEnv tcl_env (kcTyClDecls decls_s) + ; return (kc_decls1 ++ kc_decls2) } + +kcTyClDecls1 :: [LTyClDecl Name] -> TcM (TcLclEnv, [LTyClDecl Name]) +kcTyClDecls1 decls + = do { -- Omit instances of type families; they are handled together + -- with the *heads* of class instances + ; let (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls + alg_at_decls = flattenATs alg_decls + + ; mod <- getModule + ; traceTc "tcTyAndCl" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls)) + + -- First check for cyclic classes + ; checkClassCycleErrs alg_decls + + -- Kind checking; see Note [Kind checking for type and class decls] + ; alg_kinds <- mapM getInitialKind alg_at_decls + ; tcExtendKindEnv alg_kinds $ do + + { (kc_syn_decls, tcl_env) <- kcSynDecls (calcSynCycles syn_decls) + ; setLclEnv tcl_env $ do + { kc_alg_decls <- mapM (wrapLocM kcTyClDecl) alg_decls + + -- Kind checking done for this group, so zonk the kind variables + -- See Note [Kind checking for type and class decls] + ; mapM_ (zonkTcKindToKind . snd) alg_kinds + + ; return (tcl_env, kc_syn_decls ++ kc_alg_decls) } } } + +flattenATs :: [LTyClDecl Name] -> [LTyClDecl Name] +flattenATs decls = concatMap flatten decls where - -- get all declarations relevant for determining the initial kind - -- environment - allDecls (decl@ClassDecl {tcdATs = ats}) = decl : [ at - | L _ at <- ats - , isFamilyDecl at] - allDecls decl | isFamInstDecl decl = [] - | otherwise = [decl] + flatten decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats + flatten decl = [decl] ------------------------------------------------------------------------- -getInitialKind :: TyClDecl Name -> TcM (Name, TcKind) +getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind) -- Only for data type, class, and indexed type declarations -- Get as much info as possible from the data, class, or indexed type decl, -- so as to maximise usefulness of error messages -getInitialKind decl +getInitialKind (L _ decl) = do { arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl) ; res_kind <- mk_res_kind decl ; return (tcdName decl, mkArrowKinds arg_kinds res_kind) } @@ -518,13 +439,13 @@ getInitialKind decl ---------------- kcSynDecls :: [SCC (LTyClDecl Name)] -> TcM ([LTyClDecl Name], -- Kind-annotated decls - [(Name,TcKind)]) -- Kind bindings + TcLclEnv) -- Kind bindings kcSynDecls [] - = return ([], []) + = do { tcl_env <- getLclEnv; return ([], tcl_env) } kcSynDecls (group : groups) - = do { (decl, nk) <- kcSynDecl group - ; (decls, nks) <- tcExtendKindEnv [nk] (kcSynDecls groups) - ; return (decl:decls, nk:nks) } + = do { (decl, nk) <- kcSynDecl group + ; (decls, tcl_env) <- tcExtendKindEnv [nk] (kcSynDecls groups) + ; return (decl:decls, tcl_env) } ---------------- kcSynDecl :: SCC (LTyClDecl Name) @@ -675,31 +596,11 @@ kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d) %************************************************************************ \begin{code} -tcSynDecls :: [LTyClDecl Name] -> TcM [TyThing] -tcSynDecls [] = return [] -tcSynDecls (decl : decls) - = do { syn_tc <- addLocM tcSynDecl decl - ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls decls) - ; return (syn_tc : syn_tcs) } +tcTyClDecl :: (Name -> RecFlag) -> LTyClDecl Name -> TcM [TyThing] - -- "type" -tcSynDecl :: TyClDecl Name -> TcM TyThing -tcSynDecl - (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) - = tcTyVarBndrs tvs $ \ tvs' -> do - { traceTc "tcd1" (ppr tc_name) - ; rhs_ty' <- tcHsKindedType rhs_ty - ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') - (typeKind rhs_ty') NoParentTyCon Nothing - ; return (ATyCon tycon) - } -tcSynDecl d = pprPanic "tcSynDecl" (ppr d) - --------------------- -tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] - -tcTyClDecl calc_isrec decl - = tcAddDeclCtxt decl (tcTyClDecl1 NoParentTyCon calc_isrec decl) +tcTyClDecl calc_isrec (L loc decl) + = setSrcSpan loc $ tcAddDeclCtxt decl $ + tcTyClDecl1 NoParentTyCon calc_isrec decl -- "type family" declarations tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] @@ -738,12 +639,24 @@ tcTyClDecl1 parent _calc_isrec ; return [ATyCon tycon] } + -- "type" +tcTyClDecl1 _parent _calc_isrec + (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) + = ASSERT( isNoParent _parent ) + tcTyVarBndrs tvs $ \ tvs' -> do + { traceTc "tcd1" (ppr tc_name) + ; rhs_ty' <- tcHsKindedType rhs_ty + ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') + (typeKind rhs_ty') NoParentTyCon Nothing + ; return [ATyCon tycon] } + -- "newtype" and "data" -- NB: not used for newtype/data instances (whether associated or not) -tcTyClDecl1 parent calc_isrec +tcTyClDecl1 _parent calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons}) - = tcTyVarBndrs tvs $ \ tvs' -> do + = ASSERT( isNoParent _parent ) + tcTyVarBndrs tvs $ \ tvs' -> do { extra_tvs <- tcDataKindSig mb_ksig ; let final_tvs = tvs' ++ extra_tvs ; stupid_theta <- tcHsKindedContext ctxt @@ -790,7 +703,7 @@ tcTyClDecl1 parent calc_isrec mkNewTyConRhs tc_name tycon (head data_cons) ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec (want_generic && canDoGenerics data_cons) (not h98_syntax) - parent Nothing + NoParentTyCon Nothing }) ; return [ATyCon tycon] } @@ -802,7 +715,8 @@ tcTyClDecl1 _parent calc_isrec (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, tcdCtxt = ctxt, tcdMeths = meths, tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} ) - = tcTyVarBndrs tvs $ \ tvs' -> do + = ASSERT( isNoParent _parent ) + tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt ; fds' <- mapM (addLocM tc_fundep) fundeps ; sig_stuff <- tcClassSigs class_name sigs meths @@ -1038,8 +952,8 @@ Validity checking is done once the mutually-recursive knot has been tied, so we can look at things freely. \begin{code} -checkCycleErrs :: [LTyClDecl Name] -> TcM () -checkCycleErrs tyclss +checkClassCycleErrs :: [LTyClDecl Name] -> TcM () +checkClassCycleErrs tyclss | null cls_cycles = return () | otherwise @@ -1058,8 +972,9 @@ checkValidTyCl decl ; traceTc "Validity of" (ppr thing) ; case thing of ATyCon tc -> checkValidTyCon tc - AClass cl -> checkValidClass cl - _ -> panic "checkValidTyCl" + AClass cl -> do { checkValidClass cl + ; mapM_ (addLocM checkValidTyCl) (tcdATs decl) } + _ -> panic "checkValidTyCl" ; traceTc "Done validity of" (ppr thing) } diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index 2366731..a9ea11a 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -132,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 @@ -160,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) diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index 118bcac..a25537e 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -251,7 +251,7 @@ boundValues mod group = , bind <- bagToList binds , x <- boundThings mod bind ] _other -> error "boundValues" - tys = [ n | ns <- map hsTyClDeclBinders (hs_tyclds group) + tys = [ n | ns <- map hsTyClDeclBinders (concat (hs_tyclds group)) , n <- map found ns ] fors = concat $ map forBound (hs_fords group) where forBound lford = case unLoc lford of