From 1fa3580c54985d73178d1d396b897176a57cd7f3 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Mon, 11 Aug 2008 12:25:23 +0000 Subject: [PATCH] Fix Trac #2412: type synonyms and hs-boot recursion Max Bolingbroke found this awkward bug, which relates to the way in which hs-boot files are handled. --> HEADS UP: interface file format change: recompile everything! When we import a type synonym, we want to *refrain* from looking at its RHS until we've "tied the knot" in the module being compiled. (Reason: the type synonym might ultimately loop back to the module being compiled.) To achieve this goal we need to know the *kind* of the synonym without looking at its RHS. And to do that we need its kind recorded in the interface file. I slightly refactored the way that the IfaceSyn data constructor fields work, eliminating the previous tricky re-use of the same field as either a type or a kind. See Note [Synonym kind loop] in TcIface --- compiler/iface/BuildTyCl.lhs | 9 ++--- compiler/iface/IfaceSyn.lhs | 21 ++++++----- compiler/iface/MkIface.lhs | 11 +++--- compiler/iface/TcIface.lhs | 67 +++++++++++++++++++++++------------ compiler/typecheck/TcEnv.lhs | 29 +++++++++------ compiler/typecheck/TcRnDriver.lhs | 41 ++++++++++----------- compiler/typecheck/TcTyClsDecls.lhs | 7 ++-- compiler/vectorise/VectType.hs | 1 + 8 files changed, 110 insertions(+), 76 deletions(-) diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 8459edf..ef75d7f 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -39,22 +39,23 @@ import Data.List ------------------------------------------------------ buildSynTyCon :: Name -> [TyVar] -> SynTyConRhs + -> Kind -- Kind of the RHS -> Maybe (TyCon, [Type]) -- family instance if applicable -> TcRnIf m n TyCon -buildSynTyCon tc_name tvs rhs@(OpenSynTyCon rhs_ki _) _ +buildSynTyCon tc_name tvs rhs@(OpenSynTyCon {}) rhs_kind _ = let - kind = mkArrowKinds (map tyVarKind tvs) rhs_ki + kind = mkArrowKinds (map tyVarKind tvs) rhs_kind in return $ mkSynTyCon tc_name kind tvs rhs NoParentTyCon -buildSynTyCon tc_name tvs rhs@(SynonymTyCon rhs_ty) mb_family +buildSynTyCon tc_name tvs rhs@(SynonymTyCon {}) rhs_kind mb_family = do { -- We need to tie a knot as the coercion of a data instance depends -- on the instance representation tycon and vice versa. ; tycon <- fixM (\ tycon_rec -> do { parent <- mkParentInfo mb_family tc_name tvs tycon_rec ; let { tycon = mkSynTyCon tc_name kind tvs rhs parent - ; kind = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty) + ; kind = mkArrowKinds (map tyVarKind tvs) rhs_kind } ; return tycon }) diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 39a1fd2..c33d1f5 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -81,11 +81,10 @@ data IfaceDecl | IfaceSyn { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables - ifOpenSyn :: Bool, -- Is an open family? - ifSynRhs :: IfaceType, -- Type for an ordinary - -- synonym and kind for an - -- open family - ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) + ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon) + ifSynRhs :: Maybe IfaceType, -- Just rhs for an ordinary synonyn + -- Nothing for an open family + ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) -- Just <=> instance of family -- Invariant: ifOpenSyn == False -- for family instances @@ -426,15 +425,15 @@ pprIfaceDecl (IfaceForeign {ifName = tycon}) = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon] pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifOpenSyn = False, ifSynRhs = mono_ty, + ifSynRhs = Just mono_ty, ifFamInst = mbFamInst}) = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars) 4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst]) pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifOpenSyn = True, ifSynRhs = mono_ty}) + ifSynRhs = Nothing, ifSynKind = kind }) = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars) - 4 (dcolon <+> ppr mono_ty) + 4 (dcolon <+> ppr kind) pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, ifTyVars = tyvars, ifCons = condecls, @@ -668,7 +667,7 @@ freeNamesIfDecl d@IfaceData{} = freeNamesIfConDecls (ifCons d) freeNamesIfDecl d@IfaceSyn{} = freeNamesIfTvBndrs (ifTyVars d) &&& - freeNamesIfType (ifSynRhs d) &&& + freeNamesIfSynRhs (ifSynRhs d) &&& freeNamesIfTcFam (ifFamInst d) freeNamesIfDecl d@IfaceClass{} = freeNamesIfTvBndrs (ifTyVars d) &&& @@ -677,6 +676,10 @@ freeNamesIfDecl d@IfaceClass{} = fnList freeNamesIfClsSig (ifSigs d) -- All other changes are handled via the version info on the tycon +freeNamesIfSynRhs :: Maybe IfaceType -> NameSet +freeNamesIfSynRhs (Just ty) = freeNamesIfType ty +freeNamesIfSynRhs Nothing = emptyNameSet + freeNamesIfTcFam :: Maybe (IfaceTyCon, [IfaceType]) -> NameSet freeNamesIfTcFam (Just (tc,tys)) = freeNamesIfTc tc &&& fnList freeNamesIfType tys diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 3f1ee46..bc84cf1 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1290,8 +1290,8 @@ tyThingToIfaceDecl (ATyCon tycon) | isSynTyCon tycon = IfaceSyn { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, - ifOpenSyn = syn_isOpen, - ifSynRhs = toIfaceType syn_tyki, + ifSynRhs = syn_rhs, + ifSynKind = syn_ki, ifFamInst = famInstToIface (tyConFamInst_maybe tycon) } @@ -1312,9 +1312,10 @@ tyThingToIfaceDecl (ATyCon tycon) | otherwise = pprPanic "toIfaceDecl" (ppr tycon) where tyvars = tyConTyVars tycon - (syn_isOpen, syn_tyki) = case synTyConRhs tycon of - OpenSynTyCon ki _ -> (True , ki) - SynonymTyCon ty -> (False, ty) + (syn_rhs, syn_ki) + = case synTyConRhs tycon of + OpenSynTyCon ki _ -> (Nothing, toIfaceType ki) + SynonymTyCon ty -> (Just (toIfaceType ty), toIfaceType (typeKind ty)) ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index b36aad5..32735a4 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -356,14 +356,13 @@ tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ifIdI ; info <- tcIdInfo ignore_prags name ty info ; return (AnId (mkVanillaGlobalWithInfo name ty info)) } -tcIfaceDecl _ - (IfaceData {ifName = occ_name, - ifTyVars = tv_bndrs, - ifCtxt = ctxt, ifGadtSyntax = gadt_syn, - ifCons = rdr_cons, - ifRec = is_rec, - ifGeneric = want_generic, - ifFamInst = mb_family }) +tcIfaceDecl _ (IfaceData {ifName = occ_name, + ifTyVars = tv_bndrs, + ifCtxt = ctxt, ifGadtSyntax = gadt_syn, + ifCons = rdr_cons, + ifRec = is_rec, + ifGeneric = want_generic, + ifFamInst = mb_family }) = do { tc_name <- lookupIfaceTop occ_name ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do @@ -385,25 +384,30 @@ tcIfaceDecl _ ; return (ATyCon tycon) }} -tcIfaceDecl _ - (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, - ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty, - ifFamInst = mb_family}) +tcIfaceDecl _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, + ifSynRhs = mb_rhs_ty, + ifSynKind = kind, ifFamInst = mb_family}) = bindIfaceTyVars tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name - ; rhs_tyki <- tcIfaceType rdr_rhs_ty - ; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing - else SynonymTyCon rhs_tyki - ; famInst <- case mb_family of - Nothing -> return Nothing - Just (fam, tys) -> - do { famTyCon <- tcIfaceTyCon fam - ; insttys <- mapM tcIfaceType tys - ; return $ Just (famTyCon, insttys) - } - ; tycon <- buildSynTyCon tc_name tyvars rhs famInst + ; rhs_kind <- tcIfaceType kind -- Note [Synonym kind loop] + ; ~(rhs, fam) <- forkM (mk_doc tc_name) $ + do { rhs <- tc_syn_rhs rhs_kind mb_rhs_ty + ; fam <- tc_syn_fam mb_family + ; return (rhs, fam) } + ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind fam ; return $ ATyCon tycon } + where + mk_doc n = ptext (sLit "Type syonym") <+> ppr n + tc_syn_rhs kind Nothing = return (OpenSynTyCon kind Nothing) + tc_syn_rhs _ (Just ty) = do { rhs_ty <- tcIfaceType ty + ; return (SynonymTyCon rhs_ty) } + tc_syn_fam Nothing + = return Nothing + tc_syn_fam (Just (fam, tys)) + = do { famTyCon <- tcIfaceTyCon fam + ; insttys <- mapM tcIfaceType tys + ; return $ Just (famTyCon, insttys) } tcIfaceDecl ignore_prags (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, @@ -505,6 +509,23 @@ tcIfaceEqSpec spec ; return (tv,ty) } \end{code} +Note [Synonym kind loop] +~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that we eagerly grab the *kind* from the interface file, but +build a forkM thunk for the *rhs* (and family stuff). To see why, +consider this (Trac #2412) + +M.hs: module M where { import X; data T = MkT S } +X.hs: module X where { import {-# SOURCE #-} M; type S = T } +M.hs-boot: module M where { data T } + +When kind-checking M.hs we need S's kind. But we do not want to +find S's kind from (typeKind S-rhs), because we don't want to look at +S-rhs yet! Since S is imported from X.hi, S gets just one chance to +be defined, and we must not do that until we've finished with M.T. + +Solution: record S's kind in the interface file; now we can safely +look at it. %************************************************************************ %* * diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index feafc2e..c93dbe1 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -12,7 +12,7 @@ module TcEnv( InstBindings(..), -- Global environment - tcExtendGlobalEnv, + tcExtendGlobalEnv, setGlobalTypeEnv, tcExtendGlobalValEnv, tcLookupLocatedGlobal, tcLookupGlobal, tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon, @@ -215,28 +215,37 @@ tcLookupFamInst tycon tys \begin{code} +setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv +-- Use this to update the global type env +-- It updates both * the normal tcg_type_env field +-- * the tcg_type_env_var field seen by interface files +setGlobalTypeEnv tcg_env new_type_env + = do { -- Sync the type-envt variable seen by interface files + writeMutVar (tcg_type_env_var tcg_env) new_type_env + ; return (tcg_env { tcg_type_env = new_type_env }) } + tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r -- Given a mixture of Ids, TyCons, Classes, all from the -- module being compiled, extend the global environment tcExtendGlobalEnv things thing_inside - = do { env <- getGblEnv - ; let ge' = extendTypeEnvList (tcg_type_env env) things - ; setGblEnv (env {tcg_type_env = ge'}) thing_inside } + = do { tcg_env <- getGblEnv + ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things + ; tcg_env' <- setGlobalTypeEnv tcg_env ge' + ; setGblEnv tcg_env' thing_inside } tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a -- Same deal as tcExtendGlobalEnv, but for Ids tcExtendGlobalValEnv ids thing_inside = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside -\end{code} -\begin{code} tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r -- Extend the global environments for the type/class knot tying game +-- Just like tcExtendGlobalEnv, except the argument is a list of pairs tcExtendRecEnv gbl_stuff thing_inside - = updGblEnv upd thing_inside - where - upd env = env { tcg_type_env = extend (tcg_type_env env) } - extend env = extendNameEnvList env gbl_stuff + = do { tcg_env <- getGblEnv + ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff + ; tcg_env' <- setGlobalTypeEnv tcg_env ge' + ; setGblEnv tcg_env' thing_inside } \end{code} diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index f44f5c7..d90b40b 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -181,10 +181,11 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- Must be done after processing the exports tcg_env <- checkHiBootIface tcg_env boot_iface ; - -- Make the new type env available to stuff slurped from interface files - -- Must do this after checkHiBootIface, because the latter might add new - -- bindings for boot_dfuns, which may be mentioned in imported unfoldings - writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ; + -- The new type env is already available to stuff slurped from + -- interface files, via TcEnv.updateGlobalTypeEnv + -- It's important that this includes the stuff in checkHiBootIface, + -- because the latter might add new bindings for boot_dfuns, + -- which may be mentioned in imported unfoldings -- Rename the Haddock documentation tcg_env <- rnHaddock module_info maybe_doc tcg_env ; @@ -400,13 +401,13 @@ tcRnSrcDecls boot_iface decls (bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ; + let { final_type_env = extendTypeEnvWithIds type_env bind_ids - ; tcg_env' = tcg_env { tcg_type_env = final_type_env, - tcg_binds = binds', + ; tcg_env' = tcg_env { tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' } } ; - return (tcg_env' { tcg_binds = tcg_binds tcg_env' }) + setGlobalTypeEnv tcg_env' final_type_env } tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) @@ -501,7 +502,7 @@ tcRnHsBootDecls decls ; type_env1 = extendTypeEnvWithIds type_env0 val_ids ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids ; dfun_ids = map iDFunId inst_infos } - ; return (gbl_env { tcg_type_env = type_env2 }) + ; setGlobalTypeEnv gbl_env type_env2 }}}} spliceInHsBootErr (SpliceDecl (L loc _), _) @@ -537,15 +538,6 @@ checkHiBootIface -- Check the exports of the boot module, one by one ; mapM_ check_export boot_exports - -- Check instance declarations - ; mb_dfun_prs <- mapM check_inst boot_insts - ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds, - tcg_type_env = extendTypeEnvWithIds local_type_env boot_dfuns } - dfun_prs = catMaybes mb_dfun_prs - boot_dfuns = map fst dfun_prs - dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun) - | (boot_dfun, dfun) <- dfun_prs ] - -- Check for no family instances ; unless (null boot_fam_insts) $ panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ @@ -554,8 +546,17 @@ checkHiBootIface -- be the equivalent to the dfun bindings returned for class -- instances? We can't easily equate tycons... + -- Check instance declarations + ; mb_dfun_prs <- mapM check_inst boot_insts + ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds } + final_type_env = extendTypeEnvWithIds local_type_env boot_dfuns + dfun_prs = catMaybes mb_dfun_prs + boot_dfuns = map fst dfun_prs + dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun) + | (boot_dfun, dfun) <- dfun_prs ] + ; failIfErrsM - ; return tcg_env' } + ; setGlobalTypeEnv tcg_env' final_type_env } where check_export boot_avail -- boot_avail is exported by the boot iface | name `elem` dfun_names = return () @@ -779,10 +780,6 @@ tcTopSrcDecls boot_details tcg_env <- tcTyAndClassDecls boot_details tycl_decls ; -- If there are any errors, tcTyAndClassDecls fails here - -- Make these type and class decls available to stuff slurped from interface files - writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ; - - setGblEnv tcg_env $ do { -- Source-language instances, including derivings, -- and import the supporting declarations diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index b585650..c959233 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -293,7 +293,7 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) -- (4) construct representation tycon ; rep_tc_name <- newFamInstTyConName tc_name loc ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) - (Just (family, t_typats)) + (typeKind t_rhs) (Just (family, t_typats)) }} -- "newtype instance" and "data instance" @@ -659,7 +659,8 @@ tcSynDecl = tcTyVarBndrs tvs $ \ tvs' -> do { traceTc (text "tcd1" <+> ppr tc_name) ; rhs_ty' <- tcHsKindedType rhs_ty - ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') Nothing + ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') + (typeKind rhs_ty') Nothing ; return (ATyCon tycon) } tcSynDecl d = pprPanic "tcSynDecl" (ppr d) @@ -685,7 +686,7 @@ tcTyClDecl1 _calc_isrec -- Check that we don't use families without -XTypeFamilies ; checkTc idx_tys $ badFamInstDecl tc_name - ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) Nothing + ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) kind Nothing ; return [ATyCon tycon] } diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index 3c67855..53c8a61 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -227,6 +227,7 @@ buildPReprTyCon orig_tc vect_tc liftDs $ buildSynTyCon name tyvars (SynonymTyCon rhs_ty) + (typeKind rhs_ty) (Just $ mk_fam_inst prepr_tc vect_tc) where tyvars = tyConTyVars vect_tc -- 1.7.10.4