X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=adde9fb080b721ea8dea849372022d3c989281cb;hp=0dbf6eb6be5b129db31b59706087f24d8ff8f236;hb=11c7f334d1b98effdd62cd1fb93ca984338b3de3;hpb=6777144f7522d8db5935737e12fa451ca3211e6d diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 0dbf6eb..adde9fb 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -6,6 +6,13 @@ Type checking of type signatures in interface files \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 TcIface ( tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, @@ -43,13 +50,14 @@ import Name import NameEnv import OccName import Module -import UniqFM +import LazyUniqFM import UniqSupply import Outputable import ErrUtils import Maybes import SrcLoc import DynFlags +import Util import Control.Monad import Data.List @@ -105,6 +113,7 @@ tcImportDecl :: Name -> TcM TyThing tcImportDecl name | Just thing <- wiredInNameTyThing_maybe name = do { initIfaceTcRn (loadWiredInHomeIface name) + -- See Note [Loading instances] in LoadIface ; return thing } | otherwise = do { traceIf (text "tcImportDecl" <+> ppr name) @@ -115,7 +124,8 @@ tcImportDecl name checkWiredInTyCon :: TyCon -> TcM () -- Ensure that the home module of the TyCon (and hence its instances) --- are loaded. It might not be a wired-in tycon (see the calls in TcUnify), +-- 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) @@ -215,7 +225,6 @@ typecheckIface iface , md_rules = rules , md_vect_info = vect_info , md_exports = exports - , md_modBreaks = emptyModBreaks } } \end{code} @@ -383,14 +392,21 @@ tcIfaceDecl ignore_prags tcIfaceDecl ignore_prags (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, - ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty}) + ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty, + 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 - -- !!!TODO: read mb_family info from iface and pass as last argument - ; tycon <- buildSynTyCon tc_name tyvars rhs Nothing + ; 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 ; return $ ATyCon tycon } @@ -404,11 +420,11 @@ tcIfaceDecl ignore_prags = bindIfaceTyVars tv_bndrs $ \ tyvars -> do { cls_name <- lookupIfaceTop occ_name ; ctxt <- tcIfaceCtxt rdr_ctxt - ; sigs <- mappM tc_sig rdr_sigs - ; fds <- mappM tc_fd rdr_fds - ; ats' <- mappM (tcIfaceDecl ignore_prags) rdr_ats + ; 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) - ; cls <- buildClass cls_name tyvars ctxt fds ats sigs tc_isrec + ; cls <- buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec ; return (AClass cls) } where tc_sig (IfaceClassOp occ dm rdr_ty) @@ -421,8 +437,8 @@ tcIfaceDecl ignore_prags mk_doc op_name op_ty = ptext SLIT("Class op") <+> sep [ppr op_name, ppr op_ty] - tc_fd (tvs1, tvs2) = do { tvs1' <- mappM tcIfaceTyVar tvs1 - ; tvs2' <- mappM tcIfaceTyVar tvs2 + tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1 + ; tvs2' <- mapM tcIfaceTyVar tvs2 ; return (tvs1', tvs2') } -- For each AT argument compute the position of the corresponding class @@ -447,7 +463,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons = case if_cons of IfAbstractTyCon -> return mkAbstractTyConRhs IfOpenDataTyCon -> return mkOpenDataTyConRhs - IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons + IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons ; return (mkDataTyConRhs data_cons) } IfNewTyCon con -> do { data_con <- tc_con_decl con ; mkNewTyConRhs tycon_name tycon data_con } @@ -473,8 +489,8 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons -- Read the argument types, but lazily to avoid faulting in -- the component types unless they are really needed - ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args) - ; lbl_names <- mappM lookupIfaceTop field_lbls + ; arg_tys <- forkM (mk_doc name) (mapM tcIfaceType args) + ; lbl_names <- mapM lookupIfaceTop field_lbls ; buildDataCon name is_infix {- Not infix -} stricts lbl_names @@ -490,7 +506,7 @@ tcIfaceEqSpec spec do_item (occ, if_ty) = do { tv <- tcIfaceTyVar (occNameFS occ) ; ty <- tcIfaceType if_ty ; return (tv,ty) } -\end{code} +\end{code} %************************************************************************ @@ -512,12 +528,12 @@ tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, ifFamInstFam = fam, ifFamInstTys = mb_tcs }) --- = do { tycon' <- forkM (ptext SLIT("Inst tycon") <+> ppr tycon) $ +-- { tycon' <- forkM (ptext SLIT("Inst tycon") <+> ppr tycon) $ -- ^^^this line doesn't work, but vvv this does => CPP in Haskell = evil! - = do { tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $ - tcIfaceTyCon tycon - ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs - ; return (mkImportedFamInst fam mb_tcs' tycon') } + = do tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $ + tcIfaceTyCon tycon + let mb_tcs' = map (fmap ifaceTyConName) mb_tcs + return (mkImportedFamInst fam mb_tcs' tycon') \end{code} @@ -547,12 +563,11 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd -- Typecheck the payload lazily, in the hope it'll never be looked at forkM (ptext SLIT("Rule") <+> ftext name) $ bindIfaceBndrs bndrs $ \ bndrs' -> - do { args' <- mappM tcIfaceExpr args + do { args' <- mapM tcIfaceExpr args ; rhs' <- tcIfaceExpr rhs ; return (bndrs', args', rhs') } ; let mb_tcs = map ifTopFreeName args - ; lcl <- getLclEnv - ; returnM (Rule { ru_name = name, ru_fn = fn, ru_act = act, + ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs', ru_rough = mb_tcs, @@ -583,24 +598,85 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd \begin{code} tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo -tcIfaceVectInfo mod typeEnv (IfaceVectInfo names) - = do { ccVars <- mapM ccMapping names - ; return $ VectInfo (mkVarEnv ccVars) +tcIfaceVectInfo mod typeEnv (IfaceVectInfo + { ifaceVectInfoVar = vars + , ifaceVectInfoTyCon = tycons + , ifaceVectInfoTyConReuse = tyconsReuse + }) + = do { vVars <- mapM vectVarMapping vars + ; tyConRes1 <- mapM vectTyConMapping tycons + ; tyConRes2 <- mapM vectTyConReuseMapping tyconsReuse + ; let (vTyCons, vDataCons, vPAs, vIsos) = unzip4 (tyConRes1 ++ tyConRes2) + ; return $ VectInfo + { vectInfoVar = mkVarEnv vVars + , vectInfoTyCon = mkNameEnv vTyCons + , vectInfoDataCon = mkNameEnv (concat vDataCons) + , vectInfoPADFun = mkNameEnv vPAs + , vectInfoIso = mkNameEnv vIsos + } } where - ccMapping name - = do { ccName <- lookupOrig mod (mkCloOcc (nameOccName name)) - ; let { var = lookup name - ; ccVar = lookup ccName + vectVarMapping name + = do { vName <- lookupOrig mod (mkVectOcc (nameOccName name)) + ; let { var = lookupVar name + ; vVar = lookupVar vName + } + ; return (var, (var, vVar)) + } + vectTyConMapping name + = do { vName <- lookupOrig mod (mkVectTyConOcc (nameOccName name)) + ; paName <- lookupOrig mod (mkPADFunOcc (nameOccName name)) + ; isoName <- lookupOrig mod (mkVectIsoOcc (nameOccName name)) + ; let { tycon = lookupTyCon name + ; vTycon = lookupTyCon vName + ; paTycon = lookupVar paName + ; isoTycon = lookupVar isoName + } + ; vDataCons <- mapM vectDataConMapping (tyConDataCons tycon) + ; return ((name, (tycon, vTycon)), -- (T, T_v) + vDataCons, -- list of (Ci, Ci_v) + (vName, (vTycon, paTycon)), -- (T_v, paT) + (name, (tycon, isoTycon))) -- (T, isoT) + } + vectTyConReuseMapping name + = do { paName <- lookupOrig mod (mkPADFunOcc (nameOccName name)) + ; isoName <- lookupOrig mod (mkVectIsoOcc (nameOccName name)) + ; let { tycon = lookupTyCon name + ; paTycon = lookupVar paName + ; isoTycon = lookupVar isoName + ; vDataCons = [ (dataConName dc, (dc, dc)) + | dc <- tyConDataCons tycon] } - ; return (var, (var, ccVar)) + ; return ((name, (tycon, tycon)), -- (T, T) + vDataCons, -- list of (Ci, Ci) + (name, (tycon, paTycon)), -- (T, paT) + (name, (tycon, isoTycon))) -- (T, isoT) + } + vectDataConMapping datacon + = do { let name = dataConName datacon + ; vName <- lookupOrig mod (mkVectDataConOcc (nameOccName name)) + ; let vDataCon = lookupDataCon vName + ; return (name, (datacon, vDataCon)) } - lookup name = case lookupTypeEnv typeEnv name of - Just (AnId var) -> var - Just _ -> - panic "TcIface.tcIfaceVectInfo: wrong TyThing" - Nothing -> - panic "TcIface.tcIfaceVectInfo: unknown name" + -- + lookupVar name = case lookupTypeEnv typeEnv name of + Just (AnId var) -> var + Just _ -> + panic "TcIface.tcIfaceVectInfo: not an id" + Nothing -> + panic "TcIface.tcIfaceVectInfo: unknown name" + lookupTyCon name = case lookupTypeEnv typeEnv name of + Just (ATyCon tc) -> tc + Just _ -> + panic "TcIface.tcIfaceVectInfo: not a tycon" + Nothing -> + panic "TcIface.tcIfaceVectInfo: unknown name" + lookupDataCon name = case lookupTypeEnv typeEnv name of + Just (ADataCon dc) -> dc + Just _ -> + panic "TcIface.tcIfaceVectInfo: not a datacon" + Nothing -> + panic "TcIface.tcIfaceVectInfo: unknown name" \end{code} %************************************************************************ @@ -628,7 +704,7 @@ tcIfacePredType (IfaceEqPred t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfac ----------------------------------------- tcIfaceCtxt :: IfaceContext -> IfL ThetaType -tcIfaceCtxt sts = mappM tcIfacePredType sts +tcIfaceCtxt sts = mapM tcIfacePredType sts \end{code} @@ -641,50 +717,45 @@ tcIfaceCtxt sts = mappM tcIfacePredType sts \begin{code} tcIfaceExpr :: IfaceExpr -> IfL CoreExpr tcIfaceExpr (IfaceType ty) - = tcIfaceType ty `thenM` \ ty' -> - returnM (Type ty') + = Type <$> tcIfaceType ty tcIfaceExpr (IfaceLcl name) - = tcIfaceLclId name `thenM` \ id -> - returnM (Var id) + = Var <$> tcIfaceLclId name + +tcIfaceExpr (IfaceTick modName tickNo) + = Var <$> tcIfaceTick modName tickNo tcIfaceExpr (IfaceExt gbl) - = tcIfaceExtId gbl `thenM` \ id -> - returnM (Var id) + = Var <$> tcIfaceExtId gbl tcIfaceExpr (IfaceLit lit) - = returnM (Lit lit) - -tcIfaceExpr (IfaceFCall cc ty) - = tcIfaceType ty `thenM` \ ty' -> - newUnique `thenM` \ u -> - returnM (Var (mkFCallId u cc ty')) - -tcIfaceExpr (IfaceTuple boxity args) - = mappM tcIfaceExpr args `thenM` \ args' -> - let - -- Put the missing type arguments back in - con_args = map (Type . exprType) args' ++ args' - in - returnM (mkApps (Var con_id) con_args) + = return (Lit lit) + +tcIfaceExpr (IfaceFCall cc ty) = do + ty' <- tcIfaceType ty + u <- newUnique + return (Var (mkFCallId u cc ty')) + +tcIfaceExpr (IfaceTuple boxity args) = do + args' <- mapM tcIfaceExpr args + -- Put the missing type arguments back in + let con_args = map (Type . exprType) args' ++ args' + return (mkApps (Var con_id) con_args) where arity = length args con_id = dataConWorkId (tupleCon boxity arity) tcIfaceExpr (IfaceLam bndr body) - = bindIfaceBndr bndr $ \ bndr' -> - tcIfaceExpr body `thenM` \ body' -> - returnM (Lam bndr' body') + = bindIfaceBndr bndr $ \bndr' -> + Lam bndr' <$> tcIfaceExpr body tcIfaceExpr (IfaceApp fun arg) - = tcIfaceExpr fun `thenM` \ fun' -> - tcIfaceExpr arg `thenM` \ arg' -> - returnM (App fun' arg') + = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg -tcIfaceExpr (IfaceCase scrut case_bndr ty alts) - = tcIfaceExpr scrut `thenM` \ scrut' -> - newIfaceName (mkVarOccFS case_bndr) `thenM` \ case_bndr_name -> +tcIfaceExpr (IfaceCase scrut case_bndr ty alts) = do + scrut' <- tcIfaceExpr scrut + case_bndr_name <- newIfaceName (mkVarOccFS case_bndr) let scrut_ty = exprType scrut' case_bndr' = mkLocalId case_bndr_name scrut_ty @@ -694,60 +765,62 @@ tcIfaceExpr (IfaceCase scrut case_bndr ty alts) -- NB: not tcSplitTyConApp; we are looking at Core here -- look through non-rec newtypes to find the tycon that -- corresponds to the datacon in this case alternative - in - extendIfaceIdEnv [case_bndr'] $ - mappM (tcIfaceAlt tc_app) alts `thenM` \ alts' -> - tcIfaceType ty `thenM` \ ty' -> - returnM (Case scrut' case_bndr' ty' alts') -tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) - = do { rhs' <- tcIfaceExpr rhs - ; id <- tcIfaceLetBndr bndr - ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body) - ; return (Let (NonRec id rhs') body') } - -tcIfaceExpr (IfaceLet (IfaceRec pairs) body) - = do { ids <- mapM tcIfaceLetBndr bndrs - ; extendIfaceIdEnv ids $ do - { rhss' <- mapM tcIfaceExpr rhss - ; body' <- tcIfaceExpr body - ; return (Let (Rec (ids `zip` rhss')) body') } } + extendIfaceIdEnv [case_bndr'] $ do + alts' <- mapM (tcIfaceAlt scrut' tc_app) alts + ty' <- tcIfaceType ty + return (Case scrut' case_bndr' ty' alts') + +tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) = do + rhs' <- tcIfaceExpr rhs + id <- tcIfaceLetBndr bndr + body' <- extendIfaceIdEnv [id] (tcIfaceExpr body) + return (Let (NonRec id rhs') body') + +tcIfaceExpr (IfaceLet (IfaceRec pairs) body) = do + ids <- mapM tcIfaceLetBndr bndrs + extendIfaceIdEnv ids $ do + rhss' <- mapM tcIfaceExpr rhss + body' <- tcIfaceExpr body + return (Let (Rec (ids `zip` rhss')) body') where (bndrs, rhss) = unzip pairs tcIfaceExpr (IfaceCast expr co) = do - expr' <- tcIfaceExpr expr - co' <- tcIfaceType co - returnM (Cast expr' co') + expr' <- tcIfaceExpr expr + co' <- tcIfaceType co + return (Cast expr' co') -tcIfaceExpr (IfaceNote note expr) - = tcIfaceExpr expr `thenM` \ expr' -> +tcIfaceExpr (IfaceNote note expr) = do + expr' <- tcIfaceExpr expr case note of - IfaceInlineMe -> returnM (Note InlineMe expr') - IfaceSCC cc -> returnM (Note (SCC cc) expr') - IfaceCoreNote n -> returnM (Note (CoreNote n) expr') + IfaceInlineMe -> return (Note InlineMe expr') + IfaceSCC cc -> return (Note (SCC cc) expr') + IfaceCoreNote n -> return (Note (CoreNote n) expr') ------------------------- -tcIfaceAlt _ (IfaceDefault, names, rhs) - = ASSERT( null names ) - tcIfaceExpr rhs `thenM` \ rhs' -> - returnM (DEFAULT, [], rhs') +tcIfaceAlt _ _ (IfaceDefault, names, rhs) + = ASSERT( null names ) do + rhs' <- tcIfaceExpr rhs + return (DEFAULT, [], rhs') -tcIfaceAlt _ (IfaceLitAlt lit, names, rhs) - = ASSERT( null names ) - tcIfaceExpr rhs `thenM` \ rhs' -> - returnM (LitAlt lit, [], rhs') +tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs) + = ASSERT( null names ) do + rhs' <- tcIfaceExpr rhs + return (LitAlt lit, [], rhs') -- A case alternative is made quite a bit more complicated -- by the fact that we omit type annotations because we can -- work them out. True enough, but its not that easy! -tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) +tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) = do { con <- tcIfaceDataCon data_occ - ; ASSERT2( con `elem` tyConDataCons tycon, - ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) ) - tcIfaceDataAlt con inst_tys arg_strs rhs } +#ifdef DEBUG + ; when (not (con `elem` tyConDataCons tycon)) + (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon))) +#endif + ; tcIfaceDataAlt con inst_tys arg_strs rhs } -tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) +tcIfaceAlt _ (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) = ASSERT( isTupleTyCon tycon ) do { let [data_con] = tyConDataCons tycon ; tcIfaceDataAlt data_con inst_tys arg_occs rhs } @@ -780,9 +853,9 @@ do_one (IfaceNonRec bndr rhs) thing_inside ; return (NonRec bndr' rhs' : core_binds) }} do_one (IfaceRec pairs) thing_inside - = do { bndrs' <- mappM newExtCoreBndr bndrs + = do { bndrs' <- mapM newExtCoreBndr bndrs ; extendIfaceIdEnv bndrs' $ do - { rhss' <- mappM tcIfaceExpr rhss + { rhss' <- mapM tcIfaceExpr rhss ; core_binds <- thing_inside ; return (Rec (bndrs' `zip` rhss') : core_binds) }} where @@ -808,23 +881,22 @@ tcIdInfo ignore_prags name ty info -- we start; default assumption is that it has CAFs init_info = vanillaIdInfo - tcPrag info HsNoCafRefs = returnM (info `setCafInfo` NoCafRefs) - tcPrag info (HsArity arity) = returnM (info `setArityInfo` arity) - tcPrag info (HsStrictness str) = returnM (info `setAllStrictnessInfo` Just str) + tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) + tcPrag info (HsArity arity) = return (info `setArityInfo` arity) + tcPrag info (HsStrictness str) = return (info `setAllStrictnessInfo` Just str) -- The next two are lazy, so they don't transitively suck stuff in tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity - tcPrag info (HsInline inline_prag) = returnM (info `setInlinePragInfo` inline_prag) - tcPrag info (HsUnfold expr) - = tcPragExpr name expr `thenM` \ maybe_expr' -> + tcPrag info (HsInline inline_prag) = return (info `setInlinePragInfo` inline_prag) + tcPrag info (HsUnfold expr) = do + maybe_expr' <- tcPragExpr name expr let -- maybe_expr' doesn't get looked at if the unfolding -- is never inspected; so the typecheck doesn't even happen unfold_info = case maybe_expr' of Nothing -> noUnfolding Just expr' -> mkTopUnfolding expr' - in - returnM (info `setUnfoldingInfoLazily` unfold_info) + return (info `setUnfoldingInfoLazily` unfold_info) \end{code} \begin{code} @@ -838,7 +910,7 @@ tcWorkerInfo ty info wkr arity -- over the unfolding until it's actually used does seem worth while.) ; us <- newUniqueSupply - ; returnM (case mb_wkr_id of + ; return (case mb_wkr_id of Nothing -> info Just wkr_id -> add_wkr_info us wkr_id info) } where @@ -862,18 +934,17 @@ an unfolding that isn't going to be looked at. \begin{code} tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr) tcPragExpr name expr - = forkM_maybe doc $ - tcIfaceExpr expr `thenM` \ core_expr' -> - - -- Check for type consistency in the unfolding - ifOptM Opt_DoCoreLinting ( - get_in_scope_ids `thenM` \ in_scope -> - case lintUnfolding noSrcLoc in_scope core_expr' of - Nothing -> returnM () - Just fail_msg -> pprPanic "Iface Lint failure" (hang doc 2 fail_msg) - ) `thenM_` - - returnM core_expr' + = forkM_maybe doc $ do + core_expr' <- tcIfaceExpr expr + + -- Check for type consistency in the unfolding + ifOptM Opt_DoCoreLinting $ do + in_scope <- get_in_scope_ids + case lintUnfolding noSrcLoc in_scope core_expr' of + Nothing -> return () + Just fail_msg -> pprPanic "Iface Lint failure" (hang doc 2 fail_msg) + + return core_expr' where doc = text "Unfolding of" <+> ppr name get_in_scope_ids -- Urgh; but just for linting @@ -901,14 +972,8 @@ tcIfaceGlobal name -- Wired-in things include TyCons, DataCons, and Ids = do { ifCheckWiredInThing name; return thing } | otherwise - = do { (eps,hpt) <- getEpsAndHpt - ; dflags <- getDOpts - ; case lookupType dflags hpt (eps_PTE eps) name of { - Just thing -> return thing ; - Nothing -> do - - { env <- getGblEnv - ; case if_rec_types env of { + = do { env <- getGblEnv + ; case if_rec_types env of { -- Note [Tying the knot] Just (mod, get_type_env) | nameIsLocalOrFrom mod name -> do -- It's defined in the module being compiled @@ -920,16 +985,39 @@ tcIfaceGlobal name ; other -> do + { (eps,hpt) <- getEpsAndHpt + ; dflags <- getDOpts + ; case lookupType dflags hpt (eps_PTE eps) name of { + Just thing -> return thing ; + Nothing -> do + { mb_thing <- importDecl name -- It's imported; go get it ; case mb_thing of Failed err -> failIfM err Succeeded thing -> return thing }}}}} +-- Note [Tying the knot] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- The if_rec_types field is used in two situations: +-- +-- a) Compiling M.hs, which indiretly imports Foo.hi, which mentions M.T +-- Then we look up M.T in M's type environment, which is splatted into if_rec_types +-- after we've built M's type envt. +-- +-- b) In ghc --make, during the upsweep, we encounter M.hs, whose interface M.hi +-- is up to date. So we call typecheckIface on M.hi. This splats M.T into +-- if_rec_types so that the (lazily typechecked) decls see all the other decls +-- +-- In case (b) it's important to do the if_rec_types check *before* looking in the HPT +-- 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 @@ -950,13 +1038,11 @@ tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar) tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name ; return (check_tc (tyThingTyCon thing)) } where -#ifdef DEBUG - check_tc tc = case toIfaceTyCon tc of - IfaceTc _ -> tc - other -> pprTrace "check_tc" (ppr tc) tc -#else - check_tc tc = tc -#endif + check_tc tc + | debugIsOn = case toIfaceTyCon tc of + IfaceTc _ -> tc + other -> pprTrace "check_tc" (ppr tc) tc + | otherwise = tc -- we should be okay just returning Kind constructors without extra loading tcIfaceTyCon IfaceLiftedTypeKindTc = return liftedTypeKindTyCon tcIfaceTyCon IfaceOpenTypeKindTc = return openTypeKindTyCon @@ -1029,7 +1115,7 @@ tcIfaceLetBndr (IfLetBndr fs ty info) ----------------------- newExtCoreBndr :: IfaceLetBndr -> IfL Id -newExtCoreBndr (IfLetBndr var ty _) -- Ignoring IdInfo for now +newExtCoreBndr (IfLetBndr var ty _) -- Ignoring IdInfo for now = do { mod <- getIfModule ; name <- newGlobalBinder mod (mkVarOccFS var) noSrcSpan ; ty' <- tcIfaceType ty @@ -1045,7 +1131,7 @@ bindIfaceTyVar (occ,kind) thing_inside bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a bindIfaceTyVars bndrs thing_inside = do { names <- newIfaceNames (map mkTyVarOcc occs) - ; tyvars <- TcRnMonad.zipWithM mk_iface_tyvar names kinds + ; tyvars <- zipWithM mk_iface_tyvar names kinds ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) } where (occs,kinds) = unzip bndrs