X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcIfaceSig.lhs;h=004d7b5784db60a19166a8d6525ac79800065443;hb=cbb5beb0ecef58ae6e47fa62e144a0855644f50a;hp=94e42b72fba593292f985661a4e2e213b740ede2;hpb=2c8f04b5b883db74f449dfc8c224929fe28b027d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 94e42b7..004d7b5 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -1,47 +1,49 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcIfaceSig]{Type checking of type signatures in interface files} \begin{code} -module TcIfaceSig ( tcInterfaceSigs ) where +module TcIfaceSig ( tcInterfaceSigs, + tcVar, + tcCoreExpr, + tcCoreLamBndrs, + tcCoreBinds ) where #include "HsVersions.h" -import HsSyn ( HsDecl(..), IfaceSig(..) ) -import TcMonad -import TcMonoType ( tcHsType, tcHsTypeKind, tcTyVarScope ) -import TcEnv ( tcExtendTyVarEnv, tcExtendGlobalValEnv, - tcLookupTyConByKey, tcLookupGlobalValueMaybe, - tcExplicitLookupGlobal +import HsSyn ( CoreDecl(..), TyClDecl(..), HsTupCon(..) ) +import TcHsSyn ( TypecheckedCoreBind ) +import TcRnMonad +import TcMonoType ( tcIfaceType, kcHsSigType ) +import TcEnv ( RecTcGblEnv, tcExtendTyVarEnv, + tcExtendGlobalValEnv, + tcLookupGlobal_maybe, tcLookupRecId_maybe ) -import TcKind ( TcKind, kindToTcKind ) -import RnHsSyn ( RenamedHsDecl(..) ) +import RnHsSyn ( RenamedCoreDecl, RenamedTyClDecl ) import HsCore -import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) ) import Literal ( Literal(..) ) import CoreSyn -import CoreUtils ( coreExprType ) +import CoreUtils ( exprType ) import CoreUnfold -import MagicUFs ( MagicUnfoldingFun ) -import WwLib ( mkWrapper ) -import PrimOp ( PrimOp(..) ) +import CoreLint ( lintUnfolding ) +import WorkWrap ( mkWrapper ) -import MkId ( mkImportedId, mkUserId ) -import Id ( Id, addInlinePragma, isPrimitiveId_maybe, dataConArgTys ) +import Id ( Id, mkVanillaGlobal, mkLocalId, isDataConWrapId_maybe ) +import MkId ( mkFCallId ) import IdInfo -import SpecEnv ( addToSpecEnv ) -import Type ( mkSynTy, splitAlgTyConApp ) -import TyVar ( mkSysTyVar ) +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 Unique ( rationalTyConKey, uniqueOf ) -import TysWiredIn ( integerTy ) -import ErrUtils ( pprBagOfErrors ) -import Maybes ( maybeToBool, MaybeErr(..) ) +import UniqSupply ( initUs_ ) import Outputable -import Util ( zipWithEqual ) - +import Util ( zipWithEqual, dropList, equalLength ) +import HscTypes ( TyThing(..) ) +import CmdLineOpts ( DynFlag(..) ) \end{code} Ultimately, type signatures in interfaces will have pragmatic @@ -52,124 +54,113 @@ As always, we do not have to worry about user-pragmas in interface signatures. \begin{code} -tcInterfaceSigs :: TcEnv s -- Envt to use when checking unfoldings - -> [RenamedHsDecl] -- Ignore non-sig-decls in these decls - -> TcM s [Id] +tcInterfaceSigs :: RecTcGblEnv -- Envt to use when checking unfoldings + -> [RenamedTyClDecl] -- Ignore non-sig-decls in these decls + -> TcM [Id] -tcInterfaceSigs unf_env (SigD (IfaceSig name ty id_infos src_loc) : rest) - = tcAddSrcLoc src_loc ( - tcAddErrCtxt (ifaceSigCtxt name) ( - tcHsType ty `thenTc` \ sigma_ty -> - tcIdInfo unf_env name sigma_ty noIdInfo id_infos `thenTc` \ id_info -> - returnTc (mkImportedId name sigma_ty id_info) - )) `thenTc` \ sig_id -> - tcInterfaceSigs unf_env rest `thenTc` \ sig_ids -> - returnTc (sig_id : sig_ids) - -tcInterfaceSigs unf_env (other_decl : rest) = tcInterfaceSigs unf_env rest - -tcInterfaceSigs unf_env [] = returnTc [] +tcInterfaceSigs unf_env decls + = sequenceM [ do_one name ty id_infos src_loc + | IfaceSig {tcdName = name, tcdType = ty, + tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls] + where + in_scope_vars = [] +-- in_scope_vars = filter (nameIsLocalOrFrom mod . idName) (tcEnvIds unf_env) + -- Oops: using isLocalId instead can give a black hole + -- because it looks at the idinfo + + -- 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 + = addSrcLoc src_loc $ + addErrCtxt (ifaceSigCtxt name) $ + tcIfaceType ty `thenM` \ sigma_ty -> + tcIdInfo unf_env in_scope_vars name + sigma_ty id_infos `thenM` \ id_info -> + returnM (mkVanillaGlobal name sigma_ty id_info) \end{code} \begin{code} -tcIdInfo unf_env name ty info info_ins - = foldlTc tcPrag noIdInfo info_ins +tcIdInfo unf_env in_scope_vars name ty info_ins + = foldlM tcPrag init_info info_ins where - tcPrag info (HsArity arity) = returnTc (arity `setArityInfo` info) - tcPrag info (HsUpdate upd) = returnTc (upd `setUpdateInfo` info) - tcPrag info (HsFBType fb) = returnTc (fb `setFBTypeInfo` info) - tcPrag info (HsArgUsage au) = returnTc (au `setArgUsageInfo` info) + -- Set the CgInfo to something sensible but uninformative before + -- we start; default assumption is that it has CAFs + init_info = hasCafIdInfo - tcPrag info (HsUnfold inline expr) - = tcPragExpr unf_env name expr `thenNF_Tc` \ maybe_expr' -> + tcPrag info (HsNoCafRefs) = returnM (info `setCafInfo` NoCafRefs) + + tcPrag info (HsArity arity) = + returnM (info `setArityInfo` arity) + + tcPrag info (HsUnfold inline_prag expr) + = tcPragExpr unf_env name in_scope_vars expr `thenM` \ maybe_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' -> mkUnfolding expr' - info1 = unfold_info `setUnfoldingInfo` info - - info2 | inline = IWantToBeINLINEd `setInlinePragInfo` info1 - | otherwise = info1 + Nothing -> noUnfolding + Just expr' -> mkTopUnfolding expr' + info1 = info `setUnfoldingInfo` unfold_info + info2 = info1 `setInlinePragInfo` inline_prag in - returnTc info2 + returnM info2 - tcPrag info (HsStrictness strict) - = tcStrictness unf_env ty info strict + tcPrag info (HsStrictness strict_info) + = returnM (info `setAllStrictnessInfo` Just strict_info) - tcPrag info (HsSpecialise tyvars tys rhs) - = tcTyVarScope tyvars $ \ tyvars' -> - mapTc tcHsType tys `thenTc` \ tys' -> - tcPragExpr unf_env name rhs `thenNF_Tc` \ maybe_rhs' -> - let - -- If spec_env isn't looked at, none of this - -- actually takes place - spec_env = specInfo info - spec_env' = case maybe_rhs' of - Nothing -> spec_env - Just rhs' -> case addToSpecEnv True {- overlap ok -} spec_env tyvars' tys' rhs' of - Succeeded spec_env' -> spec_env' - Failed err -> pprTrace "tcIdInfo: bad specialisation" - (ppr name <+> ppr err) $ - spec_env - in - returnTc (spec_env' `setSpecInfo` info) + tcPrag info (HsWorker nm arity) + = tcWorkerInfo unf_env ty info nm arity \end{code} \begin{code} -tcStrictness unf_env ty info (HsStrictnessInfo demands maybe_worker) - = tcWorker unf_env maybe_worker `thenNF_Tc` \ maybe_worker_id -> - uniqSMToTcM (mkWrapper ty demands) `thenNF_Tc` \ wrap_fn -> +tcWorkerInfo unf_env ty info worker_name arity + = newUniqueSupply `thenM` \ us -> let - -- Watch out! We can't pull on maybe_worker_id too eagerly! - info' = case maybe_worker_id of - Just worker_id -> setUnfoldingInfo (mkUnfolding (wrap_fn worker_id)) $ - setInlinePragInfo IWantToBeINLINEd info + wrap_fn = initUs_ us (mkWrapper ty strict_sig) - Nothing -> info + -- 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 - has_worker = maybeToBool maybe_worker_id + Nothing -> pprTrace "tcWorkerInfo failed:" + (ppr worker_name) info in - returnTc (StrictnessInfo demands has_worker `setStrictnessInfo` info') - --- Boring to write these out, but the result type differs from the arg type... -tcStrictness unf_env ty info HsBottom - = returnTc (BottomGuaranteed `setStrictnessInfo` info) -\end{code} - -\begin{code} -tcWorker unf_env Nothing = returnNF_Tc Nothing - -tcWorker unf_env (Just (worker_name,_)) - = returnNF_Tc (trace_maybe maybe_worker_id) + returnM info' where - maybe_worker_id = tcExplicitLookupGlobal unf_env worker_name - - -- The trace is so we can see what's getting dropped - trace_maybe Nothing = pprTrace "tcWorker failed:" (ppr worker_name) Nothing - trace_maybe (Just x) = Just x + -- We are relying here on strictness info always appearing + -- before worker info, fingers crossed .... + strict_sig = case newStrictnessInfo info of + Just sig -> sig + Nothing -> pprPanic "Worker info but no strictness for" (ppr worker_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 core_expr - = forkNF_Tc ( - recoverNF_Tc no_unfolding ( - tcSetEnv unf_env $ - tcCoreExpr core_expr `thenTc` \ core_expr' -> - returnTc (Just core_expr') - )) +tcPragExpr unf_env name in_scope_vars expr + = forkM doc $ + setGblEnv unf_env $ + + tcCoreExpr expr `thenM` \ core_expr' -> + + -- Check for type consistency in the unfolding + 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 - -- The trace tells what wasn't available, for the benefit of - -- compiler hackers who want to improve it! - no_unfolding = getErrsTc `thenNF_Tc` \ (warns,errs) -> - returnNF_Tc (pprTrace "tcUnfolding failed with:" - (hang (ppr name) 4 (pprBagOfErrors errs)) - Nothing) + doc = text "unfolding of" <+> ppr name \end{code} @@ -179,12 +170,12 @@ Variables in unfoldings ****** Why? Because we know all the types and want to bind them to real Ids. \begin{code} -tcVar :: Name -> TcM s Id +tcVar :: Name -> TcM Id tcVar name - = tcLookupGlobalValueMaybe name `thenNF_Tc` \ maybe_id -> + = tcLookupGlobal_maybe name `thenM` \ maybe_id -> case maybe_id of { - Just id -> returnTc id; - Nothing -> failWithTc (noDecl name) + Just (AnId id) -> returnM id ; + Nothing -> failWithTc (noDecl name) } noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name] @@ -193,168 +184,221 @@ noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name] UfCore expressions. \begin{code} -tcCoreExpr :: UfExpr Name -> TcM s CoreExpr +tcCoreExpr :: UfExpr Name -> TcM CoreExpr + +tcCoreExpr (UfType ty) + = tcIfaceType ty `thenM` \ ty' -> + -- It might not be of kind type + returnM (Type ty') tcCoreExpr (UfVar name) - = tcVar name `thenTc` \ id -> - returnTc (Var id) + = tcVar name `thenM` \ id -> + returnM (Var id) --- rationalTy isn't built in so we have to construct it --- (the "ty" part of the incoming literal is simply bottom) -tcCoreExpr (UfLit (NoRepRational lit _)) - = tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon -> - let - rational_ty = mkSynTy rational_tycon [] - in - returnTc (Lit (NoRepRational lit rational_ty)) +tcCoreExpr (UfLit lit) + = returnM (Lit lit) --- Similarly for integers, except that it is wired in -tcCoreExpr (UfLit (NoRepInteger lit _)) - = returnTc (Lit (NoRepInteger lit integerTy)) +-- 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 `thenM` \ ty' -> + returnM (Lit (MachLitLit lit ty')) -tcCoreExpr (UfLit other_lit) - = returnTc (Lit other_lit) +tcCoreExpr (UfFCall cc ty) + = tcIfaceType ty `thenM` \ ty' -> + newUnique `thenM` \ u -> + returnM (Var (mkFCallId u cc ty')) -tcCoreExpr (UfCon con args) - = tcVar con `thenTc` \ con_id -> - mapTc tcCoreArg args `thenTc` \ args' -> - returnTc (Con con_id 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 + returnM (mkApps (Var con_id) con_args) + where + con_id = dataConWorkId (tupleCon boxity arity) + -tcCoreExpr (UfPrim prim args) - = tcCorePrim prim `thenTc` \ primop -> - mapTc tcCoreArg args `thenTc` \ args' -> - returnTc (Prim primop args') +tcCoreExpr (UfLam bndr body) + = tcCoreLamBndr bndr $ \ bndr' -> + tcCoreExpr body `thenM` \ body' -> + returnM (Lam bndr' body') tcCoreExpr (UfApp fun arg) - = tcCoreExpr fun `thenTc` \ fun' -> - tcCoreArg arg `thenTc` \ arg' -> - returnTc (App fun' arg') - -tcCoreExpr (UfCase scrut alts) - = tcCoreExpr scrut `thenTc` \ scrut' -> - tcCoreAlts (coreExprType scrut') alts `thenTc` \ alts' -> - returnTc (Case scrut' alts') - -tcCoreExpr (UfNote note expr) - = tcCoreExpr expr `thenTc` \ expr' -> - case note of - UfCoerce to_ty -> tcHsTypeKind to_ty `thenTc` \ (_,to_ty') -> - returnTc (Note (Coerce to_ty' (coreExprType expr')) expr') - UfInlineCall -> returnTc (Note InlineCall expr') - UfSCC cc -> returnTc (Note (SCC cc) expr') - -tcCoreNote (UfSCC cc) = returnTc (SCC cc) -tcCoreNote UfInlineCall = returnTc InlineCall -\end{code} - returnTc (Note note' expr') + = tcCoreExpr fun `thenM` \ fun' -> + tcCoreExpr arg `thenM` \ arg' -> + returnM (App fun' arg') -tcCoreExpr (UfLam bndr body) - = tcCoreLamBndr bndr $ \ bndr' -> - tcCoreExpr body `thenTc` \ body' -> - returnTc (Lam bndr' body') +tcCoreExpr (UfCase scrut case_bndr alts) + = tcCoreExpr scrut `thenM` \ scrut' -> + let + scrut_ty = exprType scrut' + case_bndr' = mkLocalId case_bndr scrut_ty + in + tcExtendGlobalValEnv [case_bndr'] $ + 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 `thenM` \ expr' -> + case note of + UfCoerce to_ty -> tcIfaceType to_ty `thenM` \ to_ty' -> + returnM (Note (Coerce to_ty' + (exprType expr')) 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 - = tcHsType ty `thenTc` \ ty' -> + = tcIfaceType ty `thenM` \ ty' -> let - id = mkUserId name ty' + id = mkLocalId name ty' in tcExtendGlobalValEnv [id] $ - thing_inside (ValBinder id) + thing_inside id tcCoreLamBndr (UfTyBinder name kind) thing_inside = let - tyvar = mkSysTyVar (uniqueOf name) kind + tyvar = mkTyVar name kind in - tcExtendTyVarEnv [name] [(kindToTcKind kind, tyvar)] $ - thing_inside (TyBinder tyvar) + tcExtendTyVarEnv [tyvar] (thing_inside tyvar) +tcCoreLamBndrs [] thing_inside = thing_inside [] +tcCoreLamBndrs (b:bs) thing_inside + = tcCoreLamBndr b $ \ b' -> + tcCoreLamBndrs bs $ \ bs' -> + thing_inside (b':bs') + tcCoreValBndr (UfValBinder name ty) thing_inside - = tcHsType ty `thenTc` \ ty' -> + = tcIfaceType ty `thenM` \ ty' -> let - id = mkUserId name ty' + id = mkLocalId name ty' in tcExtendGlobalValEnv [id] $ thing_inside id tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders - = mapTc tcHsType tys `thenTc` \ tys' -> + = mappM tcIfaceType tys `thenM` \ tys' -> let - ids = zipWithEqual "tcCoreValBndr" mkUserId names tys' + ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' in tcExtendGlobalValEnv ids $ thing_inside ids where - names = map (\ (UfValBinder name _) -> name) bndrs - tys = map (\ (UfValBinder _ ty) -> ty) bndrs + names = [name | UfValBinder name _ <- bndrs] + tys = [ty | UfValBinder _ ty <- bndrs] \end{code} \begin{code} -tcCoreArg (UfVarArg v) = tcVar v `thenTc` \ v' -> returnTc (VarArg v') -tcCoreArg (UfTyArg ty) = tcHsTypeKind ty `thenTc` \ (_,ty') -> returnTc (TyArg ty') -tcCoreArg (UfLitArg lit) = returnTc (LitArg lit) - -tcCoreAlts scrut_ty (UfAlgAlts alts deflt) - = mapTc tc_alt alts `thenTc` \ alts' -> - tcCoreDefault scrut_ty deflt `thenTc` \ deflt' -> - returnTc (AlgAlts alts' deflt') - where - tc_alt (con, names, rhs) - = tcVar con `thenTc` \ con' -> - let - arg_tys = dataConArgTys con' inst_tys - (tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty - arg_ids = zipWithEqual "tcCoreAlts" mkUserId names arg_tys - in - tcExtendGlobalValEnv arg_ids $ - tcCoreExpr rhs `thenTc` \ rhs' -> - returnTc (con', arg_ids, rhs') - -tcCoreAlts scrut_ty (UfPrimAlts alts deflt) - = mapTc tc_alt alts `thenTc` \ alts' -> - tcCoreDefault scrut_ty deflt `thenTc` \ deflt' -> - returnTc (PrimAlts alts' deflt') - where - tc_alt (lit, rhs) = tcCoreExpr rhs `thenTc` \ rhs' -> - returnTc (lit, rhs') - -tcCoreDefault scrut_ty UfNoDefault = returnTc NoDefault -tcCoreDefault scrut_ty (UfBindDefault name rhs) - = let - deflt_id = mkUserId name scrut_ty +tcCoreAlt scrut_ty (UfDefault, names, rhs) + = ASSERT( null names ) + tcCoreExpr rhs `thenM` \ rhs' -> + returnM (DEFAULT, [], rhs') + +tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs) + = ASSERT( null names ) + tcCoreExpr rhs `thenM` \ rhs' -> + returnM (LitAlt lit, [], rhs') + +tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs) + = ASSERT( null names ) + 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 `thenM` \ con -> + let + 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 + | 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" mkLocalId id_names arg_tys in - tcExtendGlobalValEnv [deflt_id] $ - tcCoreExpr rhs `thenTc` \ rhs' -> - returnTc (BindDefault deflt_id rhs') - + ASSERT( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars ) + tcExtendTyVarEnv ex_tyvars' $ + tcExtendGlobalValEnv arg_ids $ + tcCoreExpr rhs `thenM` \ rhs' -> + returnM (DataAlt con, ex_tyvars' ++ arg_ids, rhs') + + +tcConAlt :: UfConAlt Name -> TcM DataCon +tcConAlt (UfTupleAlt (HsTupCon boxity arity)) + = returnM (tupleCon boxity arity) + +tcConAlt (UfDataAlt con_name) + = tcVar con_name `thenM` \ con_id -> + returnM (case isDataConWrapId_maybe con_id of + Just con -> con + Nothing -> pprPanic "tcCoreAlt" (ppr con_id)) +\end{code} -tcCorePrim (UfOtherOp op) - = tcVar op `thenTc` \ op_id -> - case isPrimitiveId_maybe op_id of - Just prim_op -> returnTc prim_op - Nothing -> pprPanic "tcCorePrim" (ppr op_id) +%************************************************************************ +%* * +\subsection{Core decls} +%* * +%************************************************************************ -tcCorePrim (UfCCallOp str casm gc arg_tys res_ty) - = mapTc tcHsType arg_tys `thenTc` \ arg_tys' -> - tcHsType res_ty `thenTc` \ res_ty' -> - returnTc (CCallOp str casm gc arg_tys' res_ty') + +\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]