X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=af43f979b4db3e01470d75849dec8828dcde44a1;hb=9ffadf219cbc4f8ec57264786df936a3cee88aec;hp=c572afe36c9a0f6aa3b55111179cf5e26ec7dc3c;hpb=cb8f0e566e65c1e54de43174668fa3531970c8f5;p=ghc-hetmet.git diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index c572afe..af43f97 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -9,7 +9,7 @@ Type checking of type signatures in interface files module TcIface ( tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, - tcIfaceVectInfo, tcIfaceGlobal, tcExtCoreBindings + tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceGlobal, tcExtCoreBindings ) where #include "HsVersions.h" @@ -19,9 +19,11 @@ import LoadIface import IfaceEnv import BuildTyCl import TcRnMonad +import TcType ( tcSplitSigmaTy ) import Type import TypeRep import HscTypes +import Annotations import InstEnv import FamInstEnv import CoreSyn @@ -68,7 +70,7 @@ This module takes An IfaceDecl is populated with RdrNames, and these are not renamed to Names before typechecking, because there should be no scope errors etc. - -- For (b) consider: f = $(...h....) + -- For (b) consider: f = \$(...h....) -- where h is imported, and calls f via an hi-boot file. -- This is bad! But it is not seen as a staging error, because h -- is indeed imported. We don't want the type-checker to black-hole @@ -107,8 +109,9 @@ tcImportDecl :: Name -> TcM TyThing -- Entry point for *source-code* uses of importDecl tcImportDecl name | Just thing <- wiredInNameTyThing_maybe name - = do { initIfaceTcRn (loadWiredInHomeIface name) - -- See Note [Loading instances] in LoadIface + = do { when (needWiredInHomeIface thing) + (initIfaceTcRn (loadWiredInHomeIface name)) + -- See Note [Loading instances for wired-in things] ; return thing } | otherwise = do { traceIf (text "tcImportDecl" <+> ppr name) @@ -117,25 +120,6 @@ tcImportDecl name Succeeded thing -> return thing Failed err -> failWithTc err } -checkWiredInTyCon :: TyCon -> TcM () --- Ensure that the home module of the TyCon (and hence its instances) --- are loaded. See See Note [Loading instances] in LoadIface --- It might not be a wired-in tycon (see the calls in TcUnify), --- in which case this is a no-op. -checkWiredInTyCon tc - | not (isWiredInName tc_name) - = return () - | otherwise - = do { mod <- getModule - ; unless (mod == nameModule tc_name) - (initIfaceTcRn (loadWiredInHomeIface tc_name)) - -- Don't look for (non-existent) Float.hi when - -- compiling Float.lhs, which mentions Float of course - -- A bit yukky to call initIfaceTcRn here - } - where - tc_name = tyConName tc - importDecl :: Name -> IfM lcl (MaybeErr Message TyThing) -- Get the TyThing for this Name from an interface file -- It's not a wired-in thing -- the caller caught that @@ -144,7 +128,8 @@ importDecl name do { traceIf nd_doc -- Load the interface, which should populate the PTE - ; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem + ; mb_iface <- ASSERT2( isExternalName name, ppr name ) + loadInterface nd_doc (nameModule name) ImportBySystem ; case mb_iface of { Failed err_msg -> return (Failed err_msg) ; Succeeded _ -> do @@ -165,6 +150,83 @@ importDecl name %************************************************************************ %* * + Checks for wired-in things +%* * +%************************************************************************ + +Note [Loading instances for wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to make sure that we have at least *read* the interface files +for any module with an instance decl or RULE that we might want. + +* If the instance decl is an orphan, we have a whole separate mechanism + (loadOprhanModules) + +* If the instance decl not an orphan, then the act of looking at the + TyCon or Class will force in the defining module for the + TyCon/Class, and hence the instance decl + +* BUT, if the TyCon is a wired-in TyCon, we don't really need its interface; + but we must make sure we read its interface in case it has instances or + rules. That is what LoadIface.loadWiredInHomeInterface does. It's called + from TcIface.{tcImportDecl, checkWiredInTyCon, ifCheckWiredInThing} + +* HOWEVER, only do this for TyCons. There are no wired-in Classes. There + are some wired-in Ids, but we don't want to load their interfaces. For + example, Control.Exception.Base.recSelError is wired in, but that module + is compiled late in the base library, and we don't want to force it to + load before it's been compiled! + +All of this is done by the type checker. The renamer plays no role. +(It used to, but no longer.) + + +\begin{code} +checkWiredInTyCon :: TyCon -> TcM () +-- Ensure that the home module of the TyCon (and hence its instances) +-- are loaded. See Note [Loading instances for wired-in things] +-- It might not be a wired-in tycon (see the calls in TcUnify), +-- in which case this is a no-op. +checkWiredInTyCon tc + | not (isWiredInName tc_name) + = return () + | otherwise + = do { mod <- getModule + ; ASSERT( isExternalName tc_name ) + when (mod /= nameModule tc_name) + (initIfaceTcRn (loadWiredInHomeIface tc_name)) + -- Don't look for (non-existent) Float.hi when + -- compiling Float.lhs, which mentions Float of course + -- A bit yukky to call initIfaceTcRn here + } + where + tc_name = tyConName tc + +ifCheckWiredInThing :: TyThing -> IfL () +-- Even though we are in an interface file, we want to make +-- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double) +-- Ditto want to ensure that RULES are loaded too +-- See Note [Loading instances for wired-in things] +ifCheckWiredInThing thing + = do { mod <- getIfModule + -- Check whether we are typechecking the interface for this + -- very module. E.g when compiling the base library in --make mode + -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in + -- the HPT, so without the test we'll demand-load it into the PIT! + -- C.f. the same test in checkWiredInTyCon above + ; let name = getName thing + ; ASSERT2( isExternalName name, ppr name ) + when (needWiredInHomeIface thing && mod /= nameModule name) + (loadWiredInHomeIface name) } + +needWiredInHomeIface :: TyThing -> Bool +-- Only for TyCons; see Note [Loading instances for wired-in things] +needWiredInHomeIface (ATyCon {}) = True +needWiredInHomeIface _ = False +\end{code} + +%************************************************************************ +%* * Type-checking a complete interface %* * %************************************************************************ @@ -199,10 +261,11 @@ typecheckIface iface ; let type_env = mkNameEnv names_w_things ; writeMutVar tc_env_var type_env - -- Now do those rules and instances + -- Now do those rules, instances and annotations ; insts <- mapM tcIfaceInst (mi_insts iface) ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; rules <- tcIfaceRules ignore_prags (mi_rules iface) + ; anns <- tcIfaceAnnotations (mi_anns iface) -- Vectorisation information ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env @@ -218,6 +281,7 @@ typecheckIface iface , md_insts = insts , md_fam_insts = fam_insts , md_rules = rules + , md_anns = anns , md_vect_info = vect_info , md_exports = exports } @@ -350,20 +414,21 @@ tcIfaceDecl :: Bool -- True <=> discard IdInfo on IfaceId bindings -> IfaceDecl -> IfL TyThing -tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info}) +tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, + ifIdDetails = details, ifIdInfo = info}) = do { name <- lookupIfaceTop occ_name ; ty <- tcIfaceType iface_type + ; details <- tcIdDetails ty details ; info <- tcIdInfo ignore_prags name ty info - ; return (AnId (mkVanillaGlobal 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 }) + ; return (AnId (mkGlobalId details 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 }) = do { tc_name <- lookupIfaceTop occ_name ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do @@ -385,25 +450,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, @@ -418,7 +488,7 @@ tcIfaceDecl ignore_prags ; sigs <- mapM tc_sig rdr_sigs ; fds <- mapM tc_fd rdr_fds ; ats' <- mapM (tcIfaceDecl ignore_prags) rdr_ats - ; let ats = zipWith setTyThingPoss ats' (map ifTyVars rdr_ats) + ; let ats = map (setAssocFamilyPermutation tyvars) ats' ; cls <- buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec ; return (AClass cls) } where @@ -436,19 +506,6 @@ tcIfaceDecl ignore_prags ; tvs2' <- mapM tcIfaceTyVar tvs2 ; return (tvs1', tvs2') } - -- For each AT argument compute the position of the corresponding class - -- parameter in the class head. This will later serve as a permutation - -- vector when checking the validity of instance declarations. - setTyThingPoss (ATyCon tycon) atTyVars = - let classTyVars = map fst tv_bndrs - poss = catMaybes - . map ((`elemIndex` classTyVars) . fst) - $ atTyVars - -- There will be no Nothing, as we already passed renaming - in - ATyCon (setTyConArgPoss tycon poss) - setTyThingPoss _ _ = panic "TcIface.setTyThingPoss" - tcIfaceDecl _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) = do { name <- lookupIfaceTop rdr_name ; return (ATyCon (mkForeignTyCon name ext_name @@ -488,11 +545,15 @@ tcIfaceDataCons tycon_name tycon _ if_cons ; arg_tys <- forkM (mk_doc name) (mapM tcIfaceType args) ; lbl_names <- mapM lookupIfaceTop field_lbls + -- Remember, tycon is the representation tycon + ; let orig_res_ty = mkFamilyTyConApp tycon + (substTyVars (mkTopTvSubst eq_spec) univ_tyvars) + ; buildDataCon name is_infix {- Not infix -} stricts lbl_names univ_tyvars ex_tyvars eq_spec theta - arg_tys tycon + arg_tys orig_res_ty tycon } mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name @@ -505,6 +566,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. %************************************************************************ %* * @@ -587,6 +665,34 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd %************************************************************************ %* * + Annotations +%* * +%************************************************************************ + +\begin{code} +tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] +tcIfaceAnnotations = mapM tcIfaceAnnotation + +tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation +tcIfaceAnnotation (IfaceAnnotation target serialized) = do + target' <- tcIfaceAnnTarget target + return $ Annotation { + ann_target = target', + ann_value = serialized + } + +tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name) +tcIfaceAnnTarget (NamedTarget occ) = do + name <- lookupIfaceTop occ + return $ NamedTarget name +tcIfaceAnnTarget (ModuleTarget mod) = do + return $ ModuleTarget mod + +\end{code} + + +%************************************************************************ +%* * Vectorisation information %* * %************************************************************************ @@ -869,6 +975,17 @@ do_one (IfaceRec pairs) thing_inside %************************************************************************ \begin{code} +tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails +tcIdDetails _ IfVanillaId = return VanillaId +tcIdDetails _ IfDFunId = return DFunId +tcIdDetails ty (IfRecSelId naughty) + = return (RecSelId { sel_tycon = tc, sel_naughty = naughty }) + where + (_, _, tau) = tcSplitSigmaTy ty + tc = tyConAppTyCon (funArgTy tau) + -- A bit fragile. Relies on the selector type looking like + -- forall abc. (stupid-context) => T a b c -> blah + tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo tcIdInfo ignore_prags name ty info | ignore_prags = return vanillaIdInfo @@ -880,6 +997,7 @@ tcIdInfo ignore_prags name ty info -- we start; default assumption is that it has CAFs init_info = vanillaIdInfo + tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) tcPrag info (HsArity arity) = return (info `setArityInfo` arity) tcPrag info (HsStrictness str) = return (info `setAllStrictnessInfo` Just str) @@ -970,7 +1088,7 @@ tcIfaceGlobal :: Name -> IfL TyThing tcIfaceGlobal name | Just thing <- wiredInNameTyThing_maybe name -- Wired-in things include TyCons, DataCons, and Ids - = do { ifCheckWiredInThing name; return thing } + = do { ifCheckWiredInThing thing; return thing } | otherwise = do { env <- getGblEnv ; case if_rec_types env of { -- Note [Tying the knot] @@ -985,9 +1103,9 @@ tcIfaceGlobal name ; _ -> do - { (eps,hpt) <- getEpsAndHpt - ; dflags <- getDOpts - ; case lookupType dflags hpt (eps_PTE eps) name of { + { hsc_env <- getTopEnv + ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) + ; case mb_thing of { Just thing -> return thing ; Nothing -> do @@ -1013,21 +1131,6 @@ tcIfaceGlobal name -- Because if M.hs also has M.hs-boot, M.T will *already be* in the HPT, but in its -- emasculated form (e.g. lacking data constructors). -ifCheckWiredInThing :: Name -> IfL () --- Even though we are in an interface file, we want to make --- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double) --- Ditto want to ensure that RULES are loaded too --- See Note [Loading instances] in LoadIface -ifCheckWiredInThing name - = do { mod <- getIfModule - -- Check whether we are typechecking the interface for this - -- very module. E.g when compiling the base library in --make mode - -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in - -- the HPT, so without the test we'll demand-load it into the PIT! - -- C.f. the same test in checkWiredInTyCon above - ; unless (mod == nameModule name) - (loadWiredInHomeIface name) } - tcIfaceTyCon :: IfaceTyCon -> IfL TyCon tcIfaceTyCon IfaceIntTc = tcWiredInTyCon intTyCon tcIfaceTyCon IfaceBoolTc = tcWiredInTyCon boolTyCon @@ -1054,7 +1157,7 @@ tcIfaceTyCon IfaceUbxTupleKindTc = return ubxTupleKindTyCon -- sure the instances and RULES of this tycon are loaded -- Imagine: f :: Double -> Double tcWiredInTyCon :: TyCon -> IfL TyCon -tcWiredInTyCon tc = do { ifCheckWiredInThing (tyConName tc) +tcWiredInTyCon tc = do { ifCheckWiredInThing (ATyCon tc) ; return tc } tcIfaceClass :: Name -> IfL Class @@ -1125,13 +1228,13 @@ newExtCoreBndr (IfLetBndr var ty _) -- Ignoring IdInfo for now ----------------------- bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a bindIfaceTyVar (occ,kind) thing_inside - = do { name <- newIfaceName (mkTyVarOcc occ) + = do { name <- newIfaceName (mkTyVarOccFS occ) ; tyvar <- mk_iface_tyvar name kind ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) } bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a bindIfaceTyVars bndrs thing_inside - = do { names <- newIfaceNames (map mkTyVarOcc occs) + = do { names <- newIfaceNames (map mkTyVarOccFS occs) ; tyvars <- zipWithM mk_iface_tyvar names kinds ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) } where