X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcIfaceSig.lhs;h=5295fec764f734372e3daabd66614cfa6ad124ce;hb=e17270158bebe11ee953e3d91abf82dcd16a2203;hp=256bcae5adb4e7e47c5c104e1caa3bac683542f7;hpb=5792b355352b5e2112cffdbbd413ead8b6be7bdf;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 256bcae..5295fec 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -4,19 +4,22 @@ \section[TcIfaceSig]{Type checking of type signatures in interface files} \begin{code} -module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where +module TcIfaceSig ( tcInterfaceSigs, + tcCoreExpr, + tcCoreLamBndrs, + tcCoreBinds ) where #include "HsVersions.h" -import HsSyn ( TyClDecl(..), HsTupCon(..) ) -import TcMonad -import TcMonoType ( tcIfaceType ) -import TcEnv ( TcEnv, RecTcEnv, tcExtendTyVarEnv, - tcExtendGlobalValEnv, tcSetEnv, tcEnvIds, - tcLookupGlobal_maybe, tcLookupRecId_maybe - ) +import HsSyn ( CoreDecl(..), TyClDecl(..), HsTupCon(..) ) +import TcHsSyn ( TypecheckedCoreBind ) +import TcRnTypes +import TcRnMonad +import TcMonoType ( tcIfaceType, kcHsSigType ) +import TcEnv ( tcExtendTyVarEnv, tcExtendGlobalValEnv, tcLookupGlobalId, + tcLookupDataCon ) -import RnHsSyn ( RenamedTyClDecl ) +import RnHsSyn ( RenamedCoreDecl, RenamedTyClDecl ) import HsCore import Literal ( Literal(..) ) import CoreSyn @@ -25,19 +28,20 @@ import CoreUnfold import CoreLint ( lintUnfolding ) import WorkWrap ( mkWrapper ) -import Id ( Id, mkId, mkVanillaId, isLocalId, isDataConWrapId_maybe ) -import MkId ( mkCCallOpId ) +import Id ( Id, mkVanillaGlobal, mkLocalId ) +import MkId ( mkFCallId ) import IdInfo -import DataCon ( DataCon, dataConId, dataConSig, dataConArgTys ) -import Type ( mkTyVarTys, splitAlgTyConApp_maybe ) +import TyCon ( tyConDataCons, tyConTyVars ) +import DataCon ( DataCon, dataConWorkId, dataConExistentialTyVars, dataConArgTys ) +import Type ( mkTyVarTys, splitTyConApp ) import TysWiredIn ( tupleCon ) import Var ( mkTyVar, tyVarKind ) import Name ( Name ) -import Demand ( wwLazy ) -import ErrUtils ( pprBagOfErrors ) +import UniqSupply ( initUs_ ) import Outputable -import Util ( zipWithEqual ) -import HscTypes ( TyThing(..) ) +import Util ( zipWithEqual, dropList, equalLength ) +import HscTypes ( typeEnvIds ) +import CmdLineOpts ( DynFlag(..) ) \end{code} Ultimately, type signatures in interfaces will have pragmatic @@ -48,134 +52,165 @@ As always, we do not have to worry about user-pragmas in interface signatures. \begin{code} -tcInterfaceSigs :: RecTcEnv -- Envt to use when checking unfoldings - -> [RenamedTyClDecl] -- Ignore non-sig-decls in these decls - -> TcM [Id] +tcInterfaceSigs :: [RenamedTyClDecl] -- Ignore non-sig-decls in these decls + -> TcM TcGblEnv - -tcInterfaceSigs unf_env decls - = listTc [ do_one name ty id_infos src_loc - | IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls] +-- May 2003: +-- NOTE 1: careful about the side-effected EPS +-- in the two tcExtendGlobalValueEnv calls +-- NOTE 2: no point in tying the knot with fixM; all +-- the important knot-tying comes via the PCS global variable + +tcInterfaceSigs decls = + zapEnv (fixM (tc_interface_sigs decls)) `thenM` \ (_,sig_ids) -> + -- The zapEnv dramatically trims the environment, solely + -- to plug the space leak that would otherwise be caused + -- by a rich environment bound into lots of lazy thunks + -- The thunks are the lazily-typechecked IdInfo of the + -- imported things. + + tcExtendGlobalValEnv sig_ids getGblEnv `thenM` \ gbl_env -> + returnM gbl_env + -- We tie a knot so that the Ids read out of interfaces are in scope + -- when we read their pragmas. + -- What we rely on is that pragmas are typechecked lazily; if + -- any type errors are found (ie there's an inconsistency) + -- we silently discard the pragma + -- + -- NOTE ALSO: the knot is in two parts: + -- * Ids defined in this module are added to the typechecker envt + -- which is knot-tied by the fixM. + -- * Imported Ids are side-effected into the PCS by the + -- tcExtendGlobalValueEnv, so they will be seen there provided + -- we don't look them up too early. + -- In both cases, we must defer lookups until after the knot is tied + -- + -- We used to have a much bigger loop (in TcRnDriver), so that the + -- interface pragmas could mention variables bound in this module + -- (by mutual recn), but + -- (a) the knot is tiresomely big, and + -- (b) it black-holes when we have Template Haskell + -- + -- 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 + -- when simplifying and compiling the splice! + -- + -- Simple solution: discard any unfolding that mentions a variable + -- bound in this module (and hence not yet processed). + -- The discarding happens when forkM finds a type error. + +tc_interface_sigs decls ~(unf_env, _) + = sequenceM [do_one d | d@(IfaceSig {}) <- decls] `thenM` \ sig_ids -> + tcExtendGlobalValEnv sig_ids getGblEnv `thenM` \ gbl_env -> + returnM (gbl_env, sig_ids) where - in_scope_vars = filter isLocalId (tcEnvIds unf_env) + in_scope_vars = typeEnvIds (tcg_type_env unf_env) -- When we have hi-boot files, an unfolding might refer to -- something defined in this module, so we must build a -- suitable in-scope set. This thunk will only be poked -- if -dcore-lint is on. - do_one name ty id_infos src_loc - = tcAddSrcLoc src_loc $ - tcAddErrCtxt (ifaceSigCtxt name) $ - tcIfaceType ty `thenTc` \ sigma_ty -> + do_one IfaceSig {tcdName = name, tcdType = ty, + tcdIdInfo = id_infos, tcdLoc = src_loc} + = addSrcLoc src_loc $ + addErrCtxt (ifaceSigCtxt name) $ + tcIfaceType ty `thenM` \ sigma_ty -> tcIdInfo unf_env in_scope_vars name - sigma_ty id_infos `thenTc` \ id_info -> - returnTc (mkId name sigma_ty id_info) + sigma_ty id_infos `thenM` \ id_info -> + returnM (mkVanillaGlobal name sigma_ty id_info) \end{code} \begin{code} tcIdInfo unf_env in_scope_vars name ty info_ins - = foldlTc tcPrag constantIdInfo info_ins + = setGblEnv unf_env $ + -- Use the knot-tied environment for the IdInfo + -- In particular: typechecking unfoldings and worker names + foldlM tcPrag init_info info_ins where - tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity) - tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs) - tcPrag info HsCprInfo = returnTc (info `setCprInfo` ReturnsCPR) + -- Set the CgInfo to something sensible but uninformative before + -- 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 (HsWorker nm arity) = tcWorkerInfo ty info nm arity tcPrag info (HsUnfold inline_prag expr) - = tcPragExpr unf_env name in_scope_vars expr `thenNF_Tc` \ maybe_expr' -> + = tcPragExpr name in_scope_vars expr `thenM` \ maybe_expr' -> let - -- maybe_expr doesn't get looked at if the unfolding + -- 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' - info1 = info `setUnfoldingInfo` unfold_info - info2 = info1 `setInlinePragInfo` inline_prag in - returnTc info2 - - tcPrag info (HsStrictness strict_info) - = returnTc (info `setStrictnessInfo` strict_info) - - tcPrag info (HsWorker nm) - = tcWorkerInfo unf_env ty info nm + returnM (info `setUnfoldingInfoLazily` unfold_info + `setInlinePragInfo` inline_prag) \end{code} \begin{code} -tcWorkerInfo unf_env ty info worker_name - | not (hasArity arity_info) - = pprPanic "Worker with no arity info" (ppr worker_name) - - | otherwise - = uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn -> - let +tcWorkerInfo ty info wkr_name arity + = forkM doc (tcVar wkr_name) `thenM` \ maybe_wkr_id -> -- Watch out! We can't pull on unf_env too eagerly! - info' = case tcLookupRecId_maybe unf_env worker_name of - Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id) - `setWorkerInfo` HasWorker worker_id arity + -- Hence the forkM + + -- We return without testing maybe_wkr_id, but as soon as info is + -- looked at we will test it. That's ok, because its outside the + -- knot; and there seems no big reason to further defer the + -- tcVar lookup. (Contrast with tcPragExpr, where postponing walking + -- over the unfolding until it's actually used does seem worth while.) + newUniqueSupply `thenM` \ us -> + returnM (case maybe_wkr_id of + Nothing -> info + Just wkr_id -> info `setUnfoldingInfoLazily` mk_unfolding us wkr_id + `setWorkerInfo` HasWorker wkr_id arity) - Nothing -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info - in - returnTc info' where - -- We are relying here on arity, cpr and strictness info always appearing + doc = text "worker for" <+> ppr wkr_name + + mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id) + + -- We are relying here on strictness info always appearing -- before worker info, fingers crossed .... - arity_info = arityInfo info - arity = arityLowerBound arity_info - cpr_info = cprInfo info - (demands, res_bot) = case strictnessInfo info of - StrictnessInfo d r -> (d,r) - _ -> (take arity (repeat wwLazy),False) -- Noncommittal + strict_sig = case newStrictnessInfo info of + Just sig -> sig + Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr_name) \end{code} For unfoldings we try to do the job lazily, so that we never type check an unfolding that isn't going to be looked at. \begin{code} -tcPragExpr unf_env name in_scope_vars expr - = tcDelay unf_env doc $ - tcCoreExpr expr `thenTc` \ core_expr' -> +tcPragExpr :: Name -> [Id] -> UfExpr Name -> TcM (Maybe CoreExpr) +tcPragExpr name in_scope_vars expr + = forkM doc $ + tcCoreExpr expr `thenM` \ core_expr' -> -- Check for type consistency in the unfolding - tcGetSrcLoc `thenNF_Tc` \ src_loc -> - getDOptsTc `thenTc` \ dflags -> - case lintUnfolding dflags src_loc in_scope_vars core_expr' of - (Nothing,_) -> returnTc core_expr' -- ignore warnings - (Just fail_msg,_) -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg) + ifOptM Opt_DoCoreLinting ( + getSrcLocM `thenM` \ src_loc -> + case lintUnfolding src_loc in_scope_vars core_expr' of + Nothing -> returnM () + Just fail_msg -> failWithTc ((doc <+> text "Failed Lint") $$ fail_msg) + ) `thenM_` + + returnM core_expr' where doc = text "unfolding of" <+> ppr name - -tcDelay :: RecTcEnv -> SDoc -> TcM a -> NF_TcM (Maybe a) -tcDelay unf_env doc thing_inside - = forkNF_Tc ( - recoverNF_Tc bad_value ( - tcSetEnv unf_env thing_inside `thenTc` \ r -> - returnTc (Just r) - )) - where - -- The trace tells what wasn't available, for the benefit of - -- compiler hackers who want to improve it! - bad_value = getErrsTc `thenNF_Tc` \ (warns,errs) -> - returnNF_Tc (pprTrace "Failed:" - (hang doc 4 (pprBagOfErrors errs)) - Nothing) \end{code} Variables in unfoldings ~~~~~~~~~~~~~~~~~~~~~~~ -****** Inside here we use only the Global environment, even for locally bound variables. -****** Why? Because we know all the types and want to bind them to real Ids. \begin{code} tcVar :: Name -> TcM Id -tcVar name - = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id -> - case maybe_id of { - Just (AnId id) -> returnTc id; - Nothing -> failWithTc (noDecl name) - } - -noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name] + -- Inside here we use only the Global environment, even for locally bound variables. + -- Why? Because we know all the types and want to bind them to real Ids. +tcVar name = tcLookupGlobalId name \end{code} UfCore expressions. @@ -184,89 +219,89 @@ UfCore expressions. tcCoreExpr :: UfExpr Name -> TcM CoreExpr tcCoreExpr (UfType ty) - = tcIfaceType ty `thenTc` \ ty' -> + = tcIfaceType ty `thenM` \ ty' -> -- It might not be of kind type - returnTc (Type ty') + returnM (Type ty') tcCoreExpr (UfVar name) - = tcVar name `thenTc` \ id -> - returnTc (Var id) + = tcVar name `thenM` \ id -> + returnM (Var id) tcCoreExpr (UfLit lit) - = returnTc (Lit lit) + = returnM (Lit lit) -- The dreaded lit-lits are also similar, except here the type -- is read in explicitly rather than being implicit tcCoreExpr (UfLitLit lit ty) - = tcIfaceType ty `thenTc` \ ty' -> - returnTc (Lit (MachLitLit lit ty')) + = tcIfaceType ty `thenM` \ ty' -> + returnM (Lit (MachLitLit lit ty')) -tcCoreExpr (UfCCall cc ty) - = tcIfaceType ty `thenTc` \ ty' -> - tcGetUnique `thenNF_Tc` \ u -> - returnTc (Var (mkCCallOpId u cc ty')) +tcCoreExpr (UfFCall cc ty) + = tcIfaceType ty `thenM` \ ty' -> + newUnique `thenM` \ u -> + returnM (Var (mkFCallId u cc ty')) -tcCoreExpr (UfTuple (HsTupCon _ boxity arity) args) - = mapTc tcCoreExpr args `thenTc` \ args' -> +tcCoreExpr (UfTuple (HsTupCon boxity arity) args) + = mappM tcCoreExpr args `thenM` \ args' -> let -- Put the missing type arguments back in con_args = map (Type . exprType) args' ++ args' in - returnTc (mkApps (Var con_id) con_args) + returnM (mkApps (Var con_id) con_args) where - con_id = dataConId (tupleCon boxity arity) + con_id = dataConWorkId (tupleCon boxity arity) tcCoreExpr (UfLam bndr body) = tcCoreLamBndr bndr $ \ bndr' -> - tcCoreExpr body `thenTc` \ body' -> - returnTc (Lam bndr' body') + tcCoreExpr body `thenM` \ body' -> + returnM (Lam bndr' body') tcCoreExpr (UfApp fun arg) - = tcCoreExpr fun `thenTc` \ fun' -> - tcCoreExpr arg `thenTc` \ arg' -> - returnTc (App fun' arg') + = tcCoreExpr fun `thenM` \ fun' -> + tcCoreExpr arg `thenM` \ arg' -> + returnM (App fun' arg') tcCoreExpr (UfCase scrut case_bndr alts) - = tcCoreExpr scrut `thenTc` \ scrut' -> + = tcCoreExpr scrut `thenM` \ scrut' -> let scrut_ty = exprType scrut' - case_bndr' = mkVanillaId case_bndr scrut_ty + case_bndr' = mkLocalId case_bndr scrut_ty in tcExtendGlobalValEnv [case_bndr'] $ - mapTc (tcCoreAlt scrut_ty) alts `thenTc` \ alts' -> - returnTc (Case scrut' case_bndr' alts') + mappM (tcCoreAlt scrut_ty) alts `thenM` \ alts' -> + returnM (Case scrut' case_bndr' alts') tcCoreExpr (UfLet (UfNonRec bndr rhs) body) - = tcCoreExpr rhs `thenTc` \ rhs' -> + = tcCoreExpr rhs `thenM` \ rhs' -> tcCoreValBndr bndr $ \ bndr' -> - tcCoreExpr body `thenTc` \ body' -> - returnTc (Let (NonRec bndr' rhs') body') + tcCoreExpr body `thenM` \ body' -> + returnM (Let (NonRec bndr' rhs') body') tcCoreExpr (UfLet (UfRec pairs) body) = tcCoreValBndrs bndrs $ \ bndrs' -> - mapTc tcCoreExpr rhss `thenTc` \ rhss' -> - tcCoreExpr body `thenTc` \ body' -> - returnTc (Let (Rec (bndrs' `zip` rhss')) body') + mappM tcCoreExpr rhss `thenM` \ rhss' -> + tcCoreExpr body `thenM` \ body' -> + returnM (Let (Rec (bndrs' `zip` rhss')) body') where (bndrs, rhss) = unzip pairs tcCoreExpr (UfNote note expr) - = tcCoreExpr expr `thenTc` \ expr' -> + = tcCoreExpr expr `thenM` \ expr' -> case note of - UfCoerce to_ty -> tcIfaceType to_ty `thenTc` \ to_ty' -> - returnTc (Note (Coerce to_ty' + UfCoerce to_ty -> tcIfaceType to_ty `thenM` \ to_ty' -> + returnM (Note (Coerce to_ty' (exprType expr')) expr') - UfInlineCall -> returnTc (Note InlineCall expr') - UfInlineMe -> returnTc (Note InlineMe expr') - UfSCC cc -> returnTc (Note (SCC cc) expr') + UfInlineCall -> returnM (Note InlineCall expr') + UfInlineMe -> returnM (Note InlineMe expr') + UfSCC cc -> returnM (Note (SCC cc) expr') \end{code} \begin{code} tcCoreLamBndr (UfValBinder name ty) thing_inside - = tcIfaceType ty `thenTc` \ ty' -> + = tcIfaceType ty `thenM` \ ty' -> let - id = mkVanillaId name ty' + id = mkLocalId name ty' in tcExtendGlobalValEnv [id] $ thing_inside id @@ -284,17 +319,17 @@ tcCoreLamBndrs (b:bs) thing_inside thing_inside (b':bs') tcCoreValBndr (UfValBinder name ty) thing_inside - = tcIfaceType ty `thenTc` \ ty' -> + = tcIfaceType ty `thenM` \ ty' -> let - id = mkVanillaId name ty' + id = mkLocalId name ty' in tcExtendGlobalValEnv [id] $ thing_inside id tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders - = mapTc tcIfaceType tys `thenTc` \ tys' -> + = mappM tcIfaceType tys `thenM` \ tys' -> let - ids = zipWithEqual "tcCoreValBndr" mkVanillaId names tys' + ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' in tcExtendGlobalValEnv ids $ thing_inside ids @@ -306,63 +341,95 @@ tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders \begin{code} tcCoreAlt scrut_ty (UfDefault, names, rhs) = ASSERT( null names ) - tcCoreExpr rhs `thenTc` \ rhs' -> - returnTc (DEFAULT, [], rhs') + tcCoreExpr rhs `thenM` \ rhs' -> + returnM (DEFAULT, [], rhs') tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs) = ASSERT( null names ) - tcCoreExpr rhs `thenTc` \ rhs' -> - returnTc (LitAlt lit, [], rhs') + tcCoreExpr rhs `thenM` \ rhs' -> + returnM (LitAlt lit, [], rhs') tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs) = ASSERT( null names ) - tcCoreExpr rhs `thenTc` \ rhs' -> - tcIfaceType ty `thenTc` \ ty' -> - returnTc (LitAlt (MachLitLit str ty'), [], rhs') + tcCoreExpr rhs `thenM` \ rhs' -> + tcIfaceType ty `thenM` \ ty' -> + returnM (LitAlt (MachLitLit str ty'), [], 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! tcCoreAlt scrut_ty alt@(con, names, rhs) - = tcConAlt con `thenTc` \ con -> + = tcConAlt con `thenM` \ con -> let - (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con - - (_, inst_tys, cons) = case splitAlgTyConApp_maybe scrut_ty of - Just stuff -> stuff - Nothing -> pprPanic "tcCoreAlt" (ppr alt) - ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars] - ex_tys' = mkTyVarTys ex_tyvars' - arg_tys = dataConArgTys con (inst_tys ++ ex_tys') - id_names = drop (length ex_tyvars) names + ex_tyvars = dataConExistentialTyVars con + (tycon, inst_tys) = splitTyConApp scrut_ty -- NB: not tcSplitTyConApp + -- We are looking at Core here + main_tyvars = tyConTyVars tycon + ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars] + ex_tys' = mkTyVarTys ex_tyvars' + arg_tys = dataConArgTys con (inst_tys ++ ex_tys') + id_names = dropList ex_tyvars names arg_ids #ifdef DEBUG - | length id_names /= length arg_tys + | not (equalLength id_names arg_tys) = pprPanic "tcCoreAlts" (ppr (con, names, rhs) $$ (ppr main_tyvars <+> ppr ex_tyvars) $$ ppr arg_tys) | otherwise #endif - = zipWithEqual "tcCoreAlts" mkVanillaId id_names arg_tys + = zipWithEqual "tcCoreAlts" mkLocalId id_names arg_tys in - ASSERT( con `elem` cons && length inst_tys == length main_tyvars ) + ASSERT( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars ) tcExtendTyVarEnv ex_tyvars' $ tcExtendGlobalValEnv arg_ids $ - tcCoreExpr rhs `thenTc` \ rhs' -> - returnTc (DataAlt con, ex_tyvars' ++ arg_ids, rhs') + tcCoreExpr rhs `thenM` \ rhs' -> + returnM (DataAlt con, ex_tyvars' ++ arg_ids, rhs') tcConAlt :: UfConAlt Name -> TcM DataCon -tcConAlt (UfTupleAlt (HsTupCon _ boxity arity)) - = returnTc (tupleCon boxity arity) - -tcConAlt (UfDataAlt con_name) - = tcVar con_name `thenTc` \ con_id -> - returnTc (case isDataConWrapId_maybe con_id of - Just con -> con - Nothing -> pprPanic "tcCoreAlt" (ppr con_id)) +tcConAlt (UfTupleAlt (HsTupCon boxity arity)) + = returnM (tupleCon boxity arity) + +tcConAlt (UfDataAlt con_name) -- When reading interface files + -- the con_name will be the real name of + -- the data con + = tcLookupDataCon con_name +\end{code} + +%************************************************************************ +%* * +\subsection{Core decls} +%* * +%************************************************************************ + + +\begin{code} +tcCoreBinds :: [RenamedCoreDecl] -> TcM [TypecheckedCoreBind] +-- We don't assume the bindings are in dependency order +-- So first build the environment, then check the RHSs +tcCoreBinds ls = mappM tcCoreBinder ls `thenM` \ bndrs -> + tcExtendGlobalValEnv bndrs $ + mappM (tcCoreBind bndrs) ls + +tcCoreBinder (CoreDecl nm ty _ _) + = kcHsSigType ty `thenM_` + tcIfaceType ty `thenM` \ ty' -> + returnM (mkLocalId nm ty') + +tcCoreBind bndrs (CoreDecl nm _ rhs loc) + = tcVar nm `thenM` \ id -> + tcCoreExpr rhs `thenM` \ rhs' -> + let + mb_err = lintUnfolding loc bndrs rhs' + in + (case mb_err of + Just err -> addErr err + Nothing -> returnM ()) `thenM_` + + returnM (id, rhs') \end{code} + \begin{code} ifaceSigCtxt sig_name = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]