X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcIfaceSig.lhs;h=b922e6285250de99ac039ab467feac9ed890bd96;hb=c7e7bc25c21e28651194d9d37a53a8820932fba7;hp=727a3c21453ddeed0a8b0febec3132e739de082b;hpb=bca9dd54c2b39638cb4638aaccf6015a104a1df5;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 727a3c2..b922e62 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -8,19 +8,15 @@ module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where #include "HsVersions.h" -import HsSyn ( HsDecl(..), TyClDecl(..), HsTupCon(..) ) +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, - tcLookupGlobal_maybe, tcLookupRecId, tcEnvIds +import TcMonoType ( tcIfaceType ) +import TcEnv ( RecTcEnv, tcExtendTyVarEnv, + tcExtendGlobalValEnv, tcSetEnv, tcEnvIds, + tcLookupGlobal_maybe, tcLookupRecId_maybe ) -import RnHsSyn ( RenamedHsDecl ) +import RnHsSyn ( RenamedTyClDecl ) import HsCore import Literal ( Literal(..) ) import CoreSyn @@ -29,13 +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 ( dataConSig, dataConArgTys ) +import DataCon ( DataCon, dataConId, dataConSig, dataConArgTys ) import Type ( mkTyVarTys, splitAlgTyConApp_maybe ) +import TysWiredIn ( tupleCon ) import Var ( mkTyVar, tyVarKind ) -import Name ( Name, isLocallyDefined ) +import Name ( Name, nameIsLocalOrFrom ) import Demand ( wwLazy ) import ErrUtils ( pprBagOfErrors ) import Outputable @@ -52,35 +50,48 @@ signatures. \begin{code} tcInterfaceSigs :: RecTcEnv -- Envt to use when checking unfoldings - -> [RenamedHsDecl] -- Ignore non-sig-decls in these decls + -> 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 - | TyClD (IfaceSig name ty id_infos src_loc) <- decls] + | IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls] where - in_scope_vars = [] -- I think this will be OK - -- If so, don't pass it around - -- Was: filter isLocallyDefined (tcEnvIds unf_env) + 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 vanillaIdInfo id_infos `thenTc` \ id_info -> - returnTc (mkId name sigma_ty id_info) + sigma_ty id_infos `thenTc` \ id_info -> + returnTc (mkVanillaGlobal name sigma_ty id_info) \end{code} \begin{code} -tcIdInfo unf_env in_scope_vars name ty info info_ins - = foldlTc tcPrag vanillaIdInfo info_ins +tcIdInfo unf_env in_scope_vars name ty 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 @@ -97,35 +108,34 @@ tcIdInfo unf_env in_scope_vars name ty info 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 unf_env worker_name of - Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id) - `setWorkerInfo` HasWorker worker_id arity + info' = case tcLookupRecId_maybe unf_env worker_name of + 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 @@ -172,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) } @@ -185,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') @@ -199,22 +209,24 @@ 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')) -tcCoreExpr (UfTuple (HsTupCon name _) args) - = tcVar name `thenTc` \ con_id -> - mapTc tcCoreExpr args `thenTc` \ args' -> +tcCoreExpr (UfTuple (HsTupCon _ boxity arity) args) + = mapTc tcCoreExpr args `thenTc` \ args' -> let -- Put the missing type arguments back in con_args = map (Type . exprType) args' ++ args' in returnTc (mkApps (Var con_id) con_args) + where + con_id = dataConId (tupleCon boxity arity) + tcCoreExpr (UfLam bndr body) = tcCoreLamBndr bndr $ \ bndr' -> @@ -230,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' -> @@ -253,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') @@ -263,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 @@ -283,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 @@ -316,19 +328,15 @@ 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 -- 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@(UfDataAlt con_name, names, rhs) - = tcVar con_name `thenTc` \ con_id -> +tcCoreAlt scrut_ty alt@(con, names, rhs) + = tcConAlt con `thenTc` \ con -> let - con = case isDataConWrapId_maybe con_id of - Just con -> con - Nothing -> pprPanic "tcCoreAlt" (ppr con_id) - (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con (_, inst_tys, cons) = case splitAlgTyConApp_maybe scrut_ty of @@ -341,18 +349,29 @@ tcCoreAlt scrut_ty alt@(UfDataAlt con_name, names, rhs) arg_ids #ifdef DEBUG | length id_names /= length arg_tys - = pprPanic "tcCoreAlts" (ppr (con_name, names, rhs) $$ + = 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 ) tcExtendTyVarEnv ex_tyvars' $ tcExtendGlobalValEnv arg_ids $ tcCoreExpr rhs `thenTc` \ rhs' -> returnTc (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)) \end{code} \begin{code}