X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FTcIface.lhs;h=0167fdbb6cb3adf08c6caeebbbcb3af33ac34941;hb=ff9ab413f6ea513f1aea29c987805d022b72109a;hp=1d08095f264ae9e705041d09dc79e96ff26bffe9;hpb=4e3255388e8b99ccdae290bfcb6cd666b8c93d4a;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index 1d08095..0167fdb 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -9,10 +9,12 @@ module TcIface ( loadImportedInsts, loadImportedRules, tcExtCoreBindings ) where + #include "HsVersions.h" import IfaceSyn -import LoadIface ( loadHomeInterface, predInstGates, discardDeclPrags ) +import LoadIface ( loadHomeInterface, loadInterface, predInstGates, + discardDeclPrags, loadDecls ) import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, lookupOrig, extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName, tcIfaceTyVar, tcIfaceLclId, @@ -21,16 +23,15 @@ import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass, mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs ) import TcRnMonad import Type ( liftedTypeKind, splitTyConApp, - mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType, pprClassPred ) + mkTyVarTys, mkGenTyConApp, ThetaType, pprClassPred ) import TypeRep ( Type(..), PredType(..) ) import TyCon ( TyCon, tyConName ) import HscTypes ( ExternalPackageState(..), EpsStats(..), PackageInstEnv, HscEnv, TyThing(..), implicitTyThings, tyThingClass, tyThingTyCon, - ModIface(..), ModDetails(..), InstPool, ModGuts, - TypeEnv, mkTypeEnv, extendTypeEnv, extendTypeEnvList, - lookupTypeEnv, lookupType, typeEnvIds, - RulePool ) -import InstEnv ( extendInstEnv ) + ModIface(..), ModDetails(..), ModGuts, + mkTypeEnv, extendTypeEnv, + lookupTypeEnv, lookupType, typeEnvIds ) +import InstEnv ( extendInstEnvList ) import CoreSyn import PprCore ( pprIdRules ) import Rules ( extendRuleBaseList ) @@ -46,25 +47,22 @@ import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), setArityInfo, setInlinePragInfo, setCafInfo, vanillaIdInfo, newStrictnessInfo ) import Class ( Class ) -import TyCon ( tyConDataCons, tyConTyVars, isTupleTyCon, mkForeignTyCon ) -import DataCon ( DataCon, dataConWorkId, dataConExistentialTyVars, dataConArgTys ) -import TysWiredIn ( intTyCon, boolTyCon, charTyCon, listTyCon, parrTyCon, - tupleTyCon, tupleCon ) +import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon ) +import DataCon ( DataCon, dataConWorkId, dataConTyVars, dataConArgTys, isVanillaDataCon ) +import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon ) import Var ( TyVar, mkTyVar, tyVarKind ) -import Name ( Name, NamedThing(..), nameModuleName, nameModule, nameOccName, nameIsLocalOrFrom, - isWiredInName, wiredInNameTyThing_maybe, nameParent, nameParent_maybe ) +import Name ( Name, nameModule, nameIsLocalOrFrom, + isWiredInName, wiredInNameTyThing_maybe, nameParent ) import NameEnv import OccName ( OccName ) -import Module ( Module, ModuleName, moduleName ) +import Module ( Module ) import UniqSupply ( initUs_ ) import Outputable +import ErrUtils ( Message ) +import Maybes ( MaybeErr(..) ) import SrcLoc ( noSrcLoc ) import Util ( zipWithEqual, dropList, equalLength, zipLazy ) -import Maybes ( expectJust ) import CmdLineOpts ( DynFlag(..) ) - -import UniqFM (sizeUFM) - \end{code} This module takes @@ -111,36 +109,47 @@ where the code that e1 expands to might import some defns that also turn out to be needed by the code that e2 expands to. \begin{code} -tcImportDecl :: Name -> IfG TyThing +tcImportDecl :: Name -> TcM TyThing +-- Entry point for source-code uses of importDecl +tcImportDecl name + = do { traceIf (text "tcLookupGlobal" <+> ppr name) + ; mb_thing <- initIfaceTcRn (importDecl name) + ; case mb_thing of + Succeeded thing -> return thing + Failed err -> failWithTc err } + +importDecl :: Name -> IfM lcl (MaybeErr Message TyThing) -- Get the TyThing for this Name from an interface file -tcImportDecl name +importDecl name | Just thing <- wiredInNameTyThing_maybe name - -- This case only happens for tuples, because we pre-populate the eps_PTE - -- with other wired-in things. We can't do that for tuples because we + -- This case definitely happens for tuples, because we -- don't know how many of them we'll find + -- It also now happens for all other wired in things. We used + -- to pre-populate the eps_PTE with other wired-in things, but + -- we don't seem to do that any more. I guess it keeps the PTE smaller? = do { updateEps_ (\ eps -> eps { eps_PTE = extendTypeEnv (eps_PTE eps) thing }) - ; return thing } + ; return (Succeeded thing) } | otherwise = do { traceIf nd_doc -- Load the interface, which should populate the PTE - ; loadHomeInterface nd_doc name + ; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem + ; case mb_iface of { + Failed err_msg -> return (Failed err_msg) ; + Succeeded iface -> do -- Now look it up again; this time we should find it - ; eps <- getEps + { eps <- getEps ; case lookupTypeEnv (eps_PTE eps) name of - Just thing -> return thing - Nothing -> do { ioToIOEnv (printErrs (msg defaultErrStyle)); failM } - -- Declaration not found! - -- No errors-var to accumulate errors in, so just - -- print out the error right now - } + Just thing -> return (Succeeded thing) + Nothing -> return (Failed not_found_msg) + }}} where nd_doc = ptext SLIT("Need decl for") <+> ppr name - msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name)) - 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"), - ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")]) + not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name)) + 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"), + ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")]) \end{code} %************************************************************************ @@ -169,30 +178,18 @@ typecheckIface hsc_env iface -- It's not actually *wrong* to do so, but in fact GHCi is unable -- to handle unboxed tuples, so it must not see unfoldings. ignore_prags <- doptM Opt_IgnoreInterfacePragmas - ; let { decls | ignore_prags = map (discardDeclPrags . snd) (mi_decls iface) - | otherwise = map snd (mi_decls iface) - ; rules | ignore_prags = [] - | otherwise = mi_rules iface - ; dfuns = mi_insts iface - ; mod_name = moduleName (mi_module iface) - } - -- Typecheck the decls - ; names <- mappM (lookupOrig mod_name . ifName) decls - ; ty_things <- fixM (\ rec_ty_things -> do - { writeMutVar tc_env_var (mkNameEnv (names `zipLazy` rec_ty_things)) - -- This only makes available the "main" things, - -- but that's enough for the strictly-checked part - ; mapM tcIfaceDecl decls }) - - -- Now augment the type envt with all the implicit things - -- These will be needed when type-checking the unfoldings for - -- the IfaceIds, but this is done lazily, so writing the thing - -- now is sufficient - ; let { add_implicits main_thing = main_thing : implicitTyThings main_thing - ; type_env = mkTypeEnv (concatMap add_implicits ty_things) } + + -- Load & typecheck the decls + ; decl_things <- loadDecls ignore_prags (mi_decls iface) + + ; let type_env = mkNameEnv decl_things ; writeMutVar tc_env_var type_env -- Now do those rules and instances + ; let { rules | ignore_prags = [] + | otherwise = mi_rules iface + ; dfuns = mi_insts iface + } ; dfuns <- mapM tcIfaceInst dfuns ; rules <- mapM tcIfaceRule rules @@ -262,35 +259,22 @@ tcIfaceDecl (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info}) ; return (AnId (mkVanillaGlobal name ty info)) } tcIfaceDecl (IfaceData {ifName = occ_name, - ifTyVars = tv_bndrs, ifCtxt = rdr_ctxt, + ifTyVars = tv_bndrs, ifCons = rdr_cons, ifVrcs = arg_vrcs, ifRec = is_rec, ifGeneric = want_generic }) = do { tc_name <- lookupIfaceTop occ_name ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do - { traceIf (text "tcIfaceDecl" <+> ppr rdr_ctxt) - - ; ctxt <- forkM (ptext SLIT("Ctxt of data decl") <+> ppr tc_name) $ - tcIfaceCtxt rdr_ctxt - -- The reason for laziness here is to postpone - -- looking at the context, because the class may not - -- be in the type envt yet. E.g. - -- class Real a where { toRat :: a -> Ratio Integer } - -- data (Real a) => Ratio a = ... - -- We suck in the decl for Real, and type check it, which sucks - -- in the data type Ratio; but we must postpone typechecking the - -- context - - ; tycon <- fixM ( \ tycon -> do - { cons <- tcIfaceDataCons tycon tyvars ctxt rdr_cons - ; tycon <- buildAlgTyCon tc_name tyvars ctxt cons + { tycon <- fixM ( \ tycon -> do + { cons <- tcIfaceDataCons tycon tyvars rdr_cons + ; tycon <- buildAlgTyCon tc_name tyvars cons arg_vrcs is_rec want_generic ; return tycon }) ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) - } } + }} tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, ifSynRhs = rdr_rhs_ty, ifVrcs = arg_vrcs}) @@ -330,30 +314,58 @@ tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) ; return (ATyCon (mkForeignTyCon name ext_name liftedTypeKind 0 [])) } -tcIfaceDataCons tycon tyvars ctxt if_cons +tcIfaceDataCons tycon tc_tyvars if_cons = case if_cons of - IfAbstractTyCon -> return mkAbstractTyConRhs - IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons - ; return (mkDataTyConRhs data_cons) } - IfNewTyCon con -> do { data_con <- tc_con_decl con - ; return (mkNewTyConRhs data_con) } + IfAbstractTyCon -> return mkAbstractTyConRhs + IfDataTyCon mb_ctxt cons -> do { mb_theta <- tc_ctxt mb_ctxt + ; data_cons <- mappM tc_con_decl cons + ; return (mkDataTyConRhs mb_theta data_cons) } + IfNewTyCon con -> do { data_con <- tc_con_decl con + ; return (mkNewTyConRhs tycon data_con) } where - tc_con_decl (IfaceConDecl occ is_infix ex_tvs ex_ctxt args stricts field_lbls) - = bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do - { name <- lookupIfaceTop occ - ; ex_theta <- tcIfaceCtxt ex_ctxt -- Laziness seems not worth the bother here + tc_ctxt Nothing = return Nothing + tc_ctxt (Just ctxt) = do { theta <- tcIfaceCtxt ctxt; return (Just theta) } + + tc_con_decl (IfVanillaCon { ifConOcc = occ, ifConInfix = is_infix, ifConArgTys = args, + ifConStricts = stricts, ifConFields = field_lbls}) + = do { name <- lookupIfaceTop occ + -- 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 + ; buildDataCon name is_infix True {- Vanilla -} + stricts lbl_names + tc_tyvars [] arg_tys tycon + (mkTyVarTys tc_tyvars) -- Vanilla => we know result tys + } + + tc_con_decl (IfGadtCon { ifConTyVars = con_tvs, + ifConOcc = occ, ifConCtxt = ctxt, + ifConArgTys = args, ifConResTys = ress, + ifConStricts = stricts}) + = bindIfaceTyVars con_tvs $ \ con_tyvars -> do + { name <- lookupIfaceTop occ + ; theta <- tcIfaceCtxt ctxt -- Laziness seems not worth the bother here + -- At one stage I thought that this context checking *had* + -- to be lazy, because of possible mutual recursion between the + -- type and the classe: + -- E.g. + -- class Real a where { toRat :: a -> Ratio Integer } + -- data (Real a) => Ratio a = ... + -- But now I think that the laziness in checking class ops breaks + -- the loop, so no laziness needed -- Read the argument types, but lazily to avoid faulting in -- the component types unless they are really needed - ; arg_tys <- forkM (mk_doc name args) (mappM tcIfaceType args) ; - - ; lbl_names <- mappM lookupIfaceTop field_lbls + ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args) + ; res_tys <- forkM (mk_doc name) (mappM tcIfaceType ress) - ; buildDataCon name is_infix stricts lbl_names - tyvars ctxt ex_tyvars ex_theta - arg_tys tycon + ; buildDataCon name False {- Not infix -} False {- Not vanilla -} + stricts [{- No fields -}] + con_tyvars theta + arg_tys tycon res_tys } - mk_doc con_name args = ptext SLIT("Constructor") <+> sep [ppr con_name, ppr args] + mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name \end{code} @@ -419,7 +431,7 @@ loadImportedInsts cls tys do { eps <- getEps; return (eps_inst_env eps) } else do { traceIf (sep [ptext SLIT("Importing instances for") <+> pprClassPred cls tys, - nest 2 (vcat (map ppr iface_insts))]) + nest 2 (vcat [ppr i | (_,_,i) <- iface_insts])]) -- Typecheck the new instances ; dfuns <- initIfaceTcRn (mappM tc_inst iface_insts) @@ -427,20 +439,23 @@ loadImportedInsts cls tys -- And put them in the package instance environment ; updateEps ( \ eps -> let - inst_env' = foldl extendInstEnv (eps_inst_env eps) dfuns + inst_env' = extendInstEnvList (eps_inst_env eps) dfuns in (eps { eps_inst_env = inst_env' }, inst_env') )}} where wired_doc = ptext SLIT("Need home inteface for wired-in thing") -tc_inst (mod, inst) = initIfaceLcl mod (tcIfaceInst inst) +tc_inst (mod, loc, inst) = initIfaceLcl mod full_loc (tcIfaceInst inst) + where + full_loc = loc $$ (nest 2 (ptext SLIT("instance decl") <+> ppr inst)) tcIfaceInst :: IfaceInst -> IfL DFunId tcIfaceInst (IfaceInst { ifDFun = dfun_occ }) = tcIfaceExtId (LocalTop dfun_occ) -selectInsts :: Name -> [Name] -> ExternalPackageState -> (ExternalPackageState, [(ModuleName, IfaceInst)]) +selectInsts :: Name -> [Name] -> ExternalPackageState + -> (ExternalPackageState, [(Module, SDoc, IfaceInst)]) selectInsts cls tycons eps = (eps { eps_insts = insts', eps_stats = stats' }, iface_insts) where @@ -490,9 +505,8 @@ loadImportedRules hsc_env guts { -- Get new rules if_rules <- updateEps selectRules - ; traceIf (ptext SLIT("Importing rules:") <+> vcat (map ppr if_rules)) + ; traceIf (ptext SLIT("Importing rules:") <+> vcat [ppr r | (_,_,r) <- if_rules]) - ; let tc_rule (mod, rule) = initIfaceLcl mod (tcIfaceRule rule) ; core_rules <- mapM tc_rule if_rules -- Debug print @@ -511,8 +525,11 @@ loadImportedRules hsc_env guts ; return core_rules } - -selectRules :: ExternalPackageState -> (ExternalPackageState, [(ModuleName, IfaceRule)]) +tc_rule (mod, loc, rule) = initIfaceLcl mod full_loc (tcIfaceRule rule) + where + full_loc = loc $$ (nest 2 (ptext SLIT("rule") <+> ppr rule)) + +selectRules :: ExternalPackageState -> (ExternalPackageState, [(Module, SDoc, IfaceRule)]) -- Not terribly efficient. Look at each rule in the pool to see if -- all its gates are in the type env. If so, take it out of the pool. -- If not, trim its gates for next time. @@ -540,11 +557,18 @@ tcIfaceRule (IfaceRule {ifRuleName = rule_name, ifActivation = act, ifRuleBndrs do { fn <- tcIfaceExtId fn_rdr ; args' <- mappM tcIfaceExpr args ; rhs' <- tcIfaceExpr rhs - ; returnM (fn, (Rule rule_name act bndrs' args' rhs')) } + ; let rule = Rule rule_name act bndrs' args' rhs' + ; returnM (IdCoreRule fn (isOrphNm fn_rdr) rule) } + where tcIfaceRule (IfaceBuiltinRule fn_rdr core_rule) = do { fn <- tcIfaceExtId fn_rdr - ; returnM (fn, core_rule) } + ; returnM (IdCoreRule fn (isOrphNm fn_rdr) core_rule) } + +isOrphNm :: IfaceExtName -> Bool +-- An orphan name comes from somewhere other than this module, +-- so it has a non-local name +isOrphNm name = not (isLocalIfaceExtName name) \end{code} @@ -626,7 +650,7 @@ tcIfaceExpr (IfaceApp fun arg) tcIfaceExpr arg `thenM` \ arg' -> returnM (App fun' arg') -tcIfaceExpr (IfaceCase scrut case_bndr alts) +tcIfaceExpr (IfaceCase scrut case_bndr ty alts) = tcIfaceExpr scrut `thenM` \ scrut' -> newIfaceName case_bndr `thenM` \ case_bndr_name -> let @@ -641,7 +665,8 @@ tcIfaceExpr (IfaceCase scrut case_bndr alts) in extendIfaceIdEnv [case_bndr'] $ mappM (tcIfaceAlt tc_app) alts `thenM` \ alts' -> - returnM (Case scrut' case_bndr' alts') + tcIfaceType ty `thenM` \ ty' -> + returnM (Case scrut' case_bndr' ty' alts') tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) = tcIfaceExpr rhs `thenM` \ rhs' -> @@ -683,63 +708,60 @@ tcIfaceAlt _ (IfaceLitAlt lit, names, rhs) -- 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_occs, rhs) - = let - tycon_mod = nameModuleName (tyConName tycon) - in - tcIfaceDataCon (ExtPkg tycon_mod data_occ) `thenM` \ con -> - newIfaceNames arg_occs `thenM` \ arg_names -> - let - ex_tyvars = dataConExistentialTyVars con - main_tyvars = tyConTyVars tycon - ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- arg_names `zip` ex_tyvars] - ex_tys' = mkTyVarTys ex_tyvars' - arg_tys = dataConArgTys con (inst_tys ++ ex_tys') - id_names = dropList ex_tyvars arg_names - arg_ids -#ifdef DEBUG - | not (equalLength id_names arg_tys) - = pprPanic "tcIfaceAlts" (ppr (con, arg_names, rhs) $$ - (ppr main_tyvars <+> ppr ex_tyvars) $$ - ppr arg_tys) - | otherwise -#endif - = zipWithEqual "tcIfaceAlts" mkLocalId id_names arg_tys - in - ASSERT2( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars, - ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) $$ ppr arg_tys $$ ppr main_tyvars ) - extendIfaceTyVarEnv ex_tyvars' $ - extendIfaceIdEnv arg_ids $ - tcIfaceExpr rhs `thenM` \ rhs' -> - returnM (DataAlt con, ex_tyvars' ++ arg_ids, rhs') + = do { let tycon_mod = nameModule (tyConName tycon) + ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ) + ; ASSERT2( con `elem` tyConDataCons tycon, + ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) ) + + if isVanillaDataCon con then + tcVanillaAlt con inst_tys arg_occs rhs + else + do { -- General case + arg_names <- newIfaceNames arg_occs + ; let tyvars = [ mkTyVar name (tyVarKind tv) + | (name,tv) <- arg_names `zip` dataConTyVars con] + arg_tys = dataConArgTys con (mkTyVarTys tyvars) + id_names = dropList tyvars arg_names + arg_ids = ASSERT2( equalLength id_names arg_tys, + ppr (con, arg_names, rhs) $$ ppr tyvars $$ ppr arg_tys ) + zipWith mkLocalId id_names arg_tys + + ; rhs' <- extendIfaceTyVarEnv tyvars $ + extendIfaceIdEnv arg_ids $ + tcIfaceExpr rhs + ; return (DataAlt con, tyvars ++ arg_ids, rhs') }} tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) - = newIfaceNames arg_occs `thenM` \ arg_names -> - let - [con] = tyConDataCons tycon - arg_ids = zipWithEqual "tcIfaceAlts" mkLocalId arg_names inst_tys - in - ASSERT( isTupleTyCon tycon ) - extendIfaceIdEnv arg_ids $ - tcIfaceExpr rhs `thenM` \ rhs' -> - returnM (DataAlt con, arg_ids, rhs') + = ASSERT( isTupleTyCon tycon ) + do { let [data_con] = tyConDataCons tycon + ; tcVanillaAlt data_con inst_tys arg_occs rhs } + +tcVanillaAlt data_con inst_tys arg_occs rhs + = do { arg_names <- newIfaceNames arg_occs + ; let arg_tys = dataConArgTys data_con inst_tys + ; let arg_ids = ASSERT2( equalLength arg_names arg_tys, + ppr data_con <+> ppr inst_tys <+> ppr arg_occs $$ ppr rhs ) + zipWith mkLocalId arg_names arg_tys + ; rhs' <- extendIfaceIdEnv arg_ids (tcIfaceExpr rhs) + ; returnM (DataAlt data_con, arg_ids, rhs') } \end{code} \begin{code} -tcExtCoreBindings :: Module -> [IfaceBinding] -> IfL [CoreBind] -- Used for external core -tcExtCoreBindings mod [] = return [] -tcExtCoreBindings mod (b:bs) = do_one mod b (tcExtCoreBindings mod bs) +tcExtCoreBindings :: [IfaceBinding] -> IfL [CoreBind] -- Used for external core +tcExtCoreBindings [] = return [] +tcExtCoreBindings (b:bs) = do_one b (tcExtCoreBindings bs) -do_one :: Module -> IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind] -do_one mod (IfaceNonRec bndr rhs) thing_inside +do_one :: IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind] +do_one (IfaceNonRec bndr rhs) thing_inside = do { rhs' <- tcIfaceExpr rhs - ; bndr' <- newExtCoreBndr mod bndr + ; bndr' <- newExtCoreBndr bndr ; extendIfaceIdEnv [bndr'] $ do { core_binds <- thing_inside ; return (NonRec bndr' rhs' : core_binds) }} -do_one mod (IfaceRec pairs) thing_inside - = do { bndrs' <- mappM (newExtCoreBndr mod) bndrs +do_one (IfaceRec pairs) thing_inside + = do { bndrs' <- mappM newExtCoreBndr bndrs ; extendIfaceIdEnv bndrs' $ do { rhss' <- mappM tcIfaceExpr rhss ; core_binds <- thing_inside @@ -851,28 +873,31 @@ tcPragExpr name expr %************************************************************************ \begin{code} -tcIfaceGlobal :: Name -> IfM a TyThing +tcIfaceGlobal :: Name -> IfL TyThing tcIfaceGlobal name = do { (eps,hpt) <- getEpsAndHpt ; case lookupType hpt (eps_PTE eps) name of { Just thing -> return thing ; - Nothing -> + Nothing -> do - setLclEnv () $ do -- This gets us back to IfG, mainly to - -- pacify get_type_env; rather untidy { env <- getGblEnv - ; case if_rec_types env of + ; case if_rec_types env of { Just (mod, get_type_env) | nameIsLocalOrFrom mod name -> do -- It's defined in the module being compiled - { type_env <- get_type_env + { type_env <- setLclEnv () get_type_env -- yuk ; case lookupNameEnv type_env name of Just thing -> return thing Nothing -> pprPanic "tcIfaceGlobal (local): not found:" (ppr name $$ ppr type_env) } - other -> tcImportDecl name -- It's imported; go get it - }}} + ; other -> do + + { mb_thing <- importDecl name -- It's imported; go get it + ; case mb_thing of + Failed err -> failIfM err + Succeeded thing -> return thing + }}}}} tcIfaceTyCon :: IfaceTyCon -> IfL TyCon tcIfaceTyCon IfaceIntTc = return intTyCon @@ -944,9 +969,10 @@ bindIfaceIds bndrs thing_inside ----------------------- -newExtCoreBndr :: Module -> (OccName, IfaceType) -> IfL Id -newExtCoreBndr mod (occ, ty) - = do { name <- newGlobalBinder mod occ Nothing noSrcLoc +newExtCoreBndr :: (OccName, IfaceType) -> IfL Id +newExtCoreBndr (occ, ty) + = do { mod <- getIfModule + ; name <- newGlobalBinder mod occ Nothing noSrcLoc ; ty' <- tcIfaceType ty ; return (mkLocalId name ty') }