X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcIfaceSig.lhs;h=f83b337f3e35218aa679f4ab28c5295705c5e97b;hb=d8a9b534050f62f65d9db0d69aad9733f687ef8b;hp=247b3b82d3aaf9b0aff7cf39ad1756747f64669d;hpb=33d4a6bdb9a9b267464459aa049a25f4542305f1;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 247b3b8..f83b337 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -4,23 +4,25 @@ \section[TcIfaceSig]{Type checking of type signatures in interface files} \begin{code} -module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where +module TcIfaceSig ( tcInterfaceSigs, + tcDelay, + tcVar, + tcCoreExpr, + tcCoreLamBndrs, + tcCoreBinds ) where #include "HsVersions.h" -import HsSyn ( HsDecl(..), TyClDecl(..), HsTupCon(..) ) +import HsSyn ( TyClDecl(..), HsTupCon(..) ) +import TcHsSyn ( TypecheckedCoreBind ) 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, tcExtendTyVarEnv, - tcExtendGlobalValEnv, tcSetEnv, - tcLookupGlobal_maybe, explicitLookupId, 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,17 +31,19 @@ import CoreUnfold import CoreLint ( lintUnfolding ) import WorkWrap ( mkWrapper ) -import Id ( Id, mkId, mkVanillaId, isDataConWrapId_maybe ) -import MkId ( mkCCallOpId ) +import Id ( Id, mkVanillaGlobal, mkLocalId, idName, isDataConWrapId_maybe ) +import Module ( Module ) +import MkId ( mkFCallId ) import IdInfo -import DataCon ( dataConSig, dataConArgTys ) -import Type ( mkTyVarTys, splitAlgTyConApp_maybe, unUsgTy ) +import TyCon ( tyConDataCons, tyConTyVars ) +import DataCon ( DataCon, dataConWorkId, dataConExistentialTyVars, dataConArgTys ) +import Type ( Type, mkTyVarTys, splitTyConApp ) +import TysWiredIn ( tupleCon ) import Var ( mkTyVar, tyVarKind ) -import Name ( Name, isLocallyDefined ) -import Demand ( wwLazy ) +import Name ( Name, nameIsLocalOrFrom ) import ErrUtils ( pprBagOfErrors ) import Outputable -import Util ( zipWithEqual ) +import Util ( zipWithEqual, dropList, equalLength ) import HscTypes ( TyThing(..) ) \end{code} @@ -51,33 +55,46 @@ As always, we do not have to worry about user-pragmas in interface signatures. \begin{code} -tcInterfaceSigs :: TcEnv -- Envt to use when checking unfoldings - -> [RenamedHsDecl] -- Ignore non-sig-decls in these decls +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 - | 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 = 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` arity) tcPrag info (HsUnfold inline_prag expr) = tcPragExpr unf_env name in_scope_vars expr `thenNF_Tc` \ maybe_expr' -> @@ -93,37 +110,32 @@ tcIdInfo unf_env in_scope_vars name ty info info_ins returnTc info2 tcPrag info (HsStrictness strict_info) - = returnTc (info `setStrictnessInfo` strict_info) + = returnTc (info `setAllStrictnessInfo` Just 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 - = uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn -> +tcWorkerInfo unf_env ty info worker_name arity + = uniqSMToTcM (mkWrapper ty strict_sig) `thenNF_Tc` \ wrap_fn -> let -- Watch out! We can't pull on unf_env too eagerly! - info' = case explicitLookupId 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 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 worker_name) \end{code} For unfoldings we try to do the job lazily, so that we never type check @@ -131,24 +143,23 @@ an unfolding that isn't going to be looked at. \begin{code} tcPragExpr unf_env name in_scope_vars expr - = tcDelay unf_env doc $ + = tcDelay unf_env doc Nothing $ tcCoreExpr expr `thenTc` \ core_expr' -> -- Check for type consistency in the unfolding tcGetSrcLoc `thenNF_Tc` \ src_loc -> - getDOptsTc `thenTc` \ dflags -> + getDOptsTc `thenNF_Tc` \ dflags -> case lintUnfolding dflags src_loc in_scope_vars core_expr' of - (Nothing,_) -> returnTc core_expr' -- ignore warnings + (Nothing,_) -> returnTc (Just core_expr') -- ignore warnings (Just fail_msg,_) -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg) where doc = text "unfolding of" <+> ppr name -tcDelay :: TcEnv -> SDoc -> TcM a -> NF_TcM (Maybe a) -tcDelay unf_env doc thing_inside +tcDelay :: RecTcEnv -> SDoc -> a -> TcM a -> NF_TcM a +tcDelay unf_env doc bad_ans thing_inside = forkNF_Tc ( recoverNF_Tc bad_value ( - tcSetEnv unf_env thing_inside `thenTc` \ r -> - returnTc (Just r) + tcSetEnv unf_env thing_inside )) where -- The trace tells what wasn't available, for the benefit of @@ -156,7 +167,7 @@ tcDelay unf_env doc thing_inside bad_value = getErrsTc `thenNF_Tc` \ (warns,errs) -> returnNF_Tc (pprTrace "Failed:" (hang doc 4 (pprBagOfErrors errs)) - Nothing) + bad_ans) \end{code} @@ -170,7 +181,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) } @@ -183,7 +194,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') @@ -197,22 +208,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' -> +tcCoreExpr (UfFCall cc ty) + = tcIfaceType ty `thenTc` \ ty' -> tcGetUnique `thenNF_Tc` \ u -> - returnTc (Var (mkCCallOpId u cc ty')) + returnTc (Var (mkFCallId 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 . unUsgTy . exprType) args' ++ args' + con_args = map (Type . exprType) args' ++ args' in returnTc (mkApps (Var con_id) con_args) + where + con_id = dataConWorkId (tupleCon boxity arity) + tcCoreExpr (UfLam bndr body) = tcCoreLamBndr bndr $ \ bndr' -> @@ -228,7 +241,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' -> @@ -251,9 +264,9 @@ 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' -> - returnTc (Note (Coerce (unUsgTy to_ty') - (unUsgTy (exprType expr'))) expr') + UfCoerce to_ty -> tcIfaceType to_ty `thenTc` \ to_ty' -> + returnTc (Note (Coerce to_ty' + (exprType expr')) expr') UfInlineCall -> returnTc (Note InlineCall expr') UfInlineMe -> returnTc (Note InlineMe expr') UfSCC cc -> returnTc (Note (SCC cc) expr') @@ -261,9 +274,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 @@ -281,17 +294,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 @@ -314,45 +327,77 @@ 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 - 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 - = pprPanic "tcCoreAlts" (ppr (con_name, names, rhs) $$ + | 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') + + +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} +%************************************************************************ +%* * +\subsection{Core decls} +%* * +%************************************************************************ + + +\begin{code} +tcCoreBinds :: [RenamedTyClDecl] -> TcM [TypecheckedCoreBind] +-- We don't assume the bindings are in dependency order +-- So first build the environment, then check the RHSs +tcCoreBinds ls = mapTc tcCoreBinder ls `thenTc` \ bndrs -> + tcExtendGlobalValEnv bndrs $ + mapTc tcCoreBind ls + +tcCoreBinder (CoreDecl { tcdName = nm, tcdType = ty }) + = tcIfaceType ty `thenTc` \ ty' -> + returnTc (mkLocalId nm ty') + +tcCoreBind (CoreDecl { tcdName = nm, tcdRhs = rhs }) + = tcVar nm `thenTc` \ id -> + tcCoreExpr rhs `thenTc` \ rhs' -> + returnTc (id, rhs') +\end{code} + + \begin{code} ifaceSigCtxt sig_name = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]