X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcIfaceSig.lhs;h=b922e6285250de99ac039ab467feac9ed890bd96;hb=d455d8a0f37aba8b7da6250519368a48a9386cca;hp=a606b163a531bef210a58a5e8e91234cd4573dfc;hpb=2fa402ddd9be4577e6824c66add1bf900e4fa3b5;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index a606b16..b922e62 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -10,13 +10,9 @@ module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where import HsSyn ( TyClDecl(..), HsTupCon(..) ) import TcMonad -import TcMonoType ( tcHsType ) - -- NB: all the tyars in interface files are kinded, - -- so tcHsType will do the Right Thing without - -- having to mess about with zonking - -import TcEnv ( TcEnv, RecTcEnv, tcExtendTyVarEnv, - tcExtendGlobalValEnv, tcSetEnv, +import TcMonoType ( tcIfaceType ) +import TcEnv ( RecTcEnv, tcExtendTyVarEnv, + tcExtendGlobalValEnv, tcSetEnv, tcEnvIds, tcLookupGlobal_maybe, tcLookupRecId_maybe ) @@ -29,14 +25,15 @@ import CoreUnfold import CoreLint ( lintUnfolding ) import WorkWrap ( mkWrapper ) -import Id ( Id, mkId, mkVanillaId, isDataConWrapId_maybe ) +import Id ( Id, mkVanillaGlobal, mkLocalId, idName, isDataConWrapId_maybe ) +import Module ( Module ) import MkId ( mkCCallOpId ) import IdInfo import DataCon ( DataCon, dataConId, dataConSig, dataConArgTys ) import Type ( mkTyVarTys, splitAlgTyConApp_maybe ) import TysWiredIn ( tupleCon ) import Var ( mkTyVar, tyVarKind ) -import Name ( Name ) +import Name ( Name, nameIsLocalOrFrom ) import Demand ( wwLazy ) import ErrUtils ( pprBagOfErrors ) import Outputable @@ -53,33 +50,48 @@ signatures. \begin{code} tcInterfaceSigs :: RecTcEnv -- Envt to use when checking unfoldings + -> Module -- This module -> [RenamedTyClDecl] -- Ignore non-sig-decls in these decls -> TcM [Id] -tcInterfaceSigs unf_env decls +tcInterfaceSigs unf_env mod decls = listTc [ do_one name ty id_infos src_loc | IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls] where - in_scope_vars = [] -- I think this will be OK + 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 = tcAddSrcLoc src_loc $ tcAddErrCtxt (ifaceSigCtxt name) $ - tcHsType ty `thenTc` \ sigma_ty -> + tcIfaceType ty `thenTc` \ sigma_ty -> tcIdInfo unf_env in_scope_vars name sigma_ty id_infos `thenTc` \ id_info -> - returnTc (mkId name sigma_ty id_info) + returnTc (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 + = foldlTc tcPrag init_info info_ins where - tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity) + -- set the CgInfo to something sensible but uninformative before + -- we start, because the default CgInfo is a panic. + init_info = vanillaIdInfo `setCgInfo` vanillaCgInfo + tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs) tcPrag info HsCprInfo = returnTc (info `setCprInfo` ReturnsCPR) + tcPrag info (HsArity arity) = + returnTc (info `setArityInfo` (ArityExactly arity) + `setCgArity` arity) + tcPrag info (HsUnfold inline_prag expr) = tcPragExpr unf_env name in_scope_vars expr `thenNF_Tc` \ maybe_expr' -> let @@ -96,35 +108,34 @@ tcIdInfo unf_env in_scope_vars name ty info_ins tcPrag info (HsStrictness strict_info) = returnTc (info `setStrictnessInfo` strict_info) - tcPrag info (HsWorker nm) - = tcWorkerInfo unf_env ty info nm + tcPrag info (HsWorker nm arity) + = tcWorkerInfo unf_env ty info nm arity \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 +tcWorkerInfo unf_env ty info worker_name arity = uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn -> let -- 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 + Just worker_id -> + info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id) + `setWorkerInfo` HasWorker worker_id arity - Nothing -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info + Nothing -> pprTrace "tcWorkerInfo failed:" + (ppr worker_name) info in returnTc info' where - -- We are relying here on arity, cpr and strictness info always appearing + -- We are relying here on cpr and 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 + + (demands, res_bot) + = case strictnessInfo info of + StrictnessInfo d r -> (d,r) + _ -> (take arity (repeat wwLazy),False) + -- Noncommittal \end{code} For unfoldings we try to do the job lazily, so that we never type check @@ -171,7 +182,7 @@ tcVar :: Name -> TcM Id tcVar name = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id -> case maybe_id of { - Just (AnId id) -> returnTc id; + Just (AnId id) -> returnTc id ; Nothing -> failWithTc (noDecl name) } @@ -184,7 +195,7 @@ UfCore expressions. tcCoreExpr :: UfExpr Name -> TcM CoreExpr tcCoreExpr (UfType ty) - = tcHsType ty `thenTc` \ ty' -> + = tcIfaceType ty `thenTc` \ ty' -> -- It might not be of kind type returnTc (Type ty') @@ -198,11 +209,11 @@ tcCoreExpr (UfLit lit) -- The dreaded lit-lits are also similar, except here the type -- is read in explicitly rather than being implicit tcCoreExpr (UfLitLit lit ty) - = tcHsType ty `thenTc` \ ty' -> + = tcIfaceType ty `thenTc` \ ty' -> returnTc (Lit (MachLitLit lit ty')) tcCoreExpr (UfCCall cc ty) - = tcHsType ty `thenTc` \ ty' -> + = tcIfaceType ty `thenTc` \ ty' -> tcGetUnique `thenNF_Tc` \ u -> returnTc (Var (mkCCallOpId u cc ty')) @@ -231,7 +242,7 @@ tcCoreExpr (UfCase scrut case_bndr alts) = tcCoreExpr scrut `thenTc` \ 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' -> @@ -254,7 +265,7 @@ tcCoreExpr (UfLet (UfRec pairs) body) tcCoreExpr (UfNote note expr) = tcCoreExpr expr `thenTc` \ expr' -> case note of - UfCoerce to_ty -> tcHsType to_ty `thenTc` \ to_ty' -> + UfCoerce to_ty -> tcIfaceType to_ty `thenTc` \ to_ty' -> returnTc (Note (Coerce to_ty' (exprType expr')) expr') UfInlineCall -> returnTc (Note InlineCall expr') @@ -264,9 +275,9 @@ tcCoreExpr (UfNote note expr) \begin{code} tcCoreLamBndr (UfValBinder name ty) thing_inside - = tcHsType ty `thenTc` \ ty' -> + = tcIfaceType ty `thenTc` \ ty' -> let - id = mkVanillaId name ty' + id = mkLocalId name ty' in tcExtendGlobalValEnv [id] $ thing_inside id @@ -284,17 +295,17 @@ tcCoreLamBndrs (b:bs) thing_inside thing_inside (b':bs') tcCoreValBndr (UfValBinder name ty) thing_inside - = tcHsType ty `thenTc` \ ty' -> + = tcIfaceType ty `thenTc` \ 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 tcHsType tys `thenTc` \ tys' -> + = mapTc tcIfaceType tys `thenTc` \ tys' -> let - ids = zipWithEqual "tcCoreValBndr" mkVanillaId names tys' + ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' in tcExtendGlobalValEnv ids $ thing_inside ids @@ -317,7 +328,7 @@ tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs) tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs) = ASSERT( null names ) tcCoreExpr rhs `thenTc` \ rhs' -> - tcHsType ty `thenTc` \ ty' -> + tcIfaceType ty `thenTc` \ ty' -> returnTc (LitAlt (MachLitLit str ty'), [], rhs') -- A case alternative is made quite a bit more complicated @@ -343,7 +354,7 @@ tcCoreAlt scrut_ty alt@(con, names, rhs) 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 ) tcExtendTyVarEnv ex_tyvars' $