X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcIfaceSig.lhs;h=247b3b82d3aaf9b0aff7cf39ad1756747f64669d;hb=33d4a6bdb9a9b267464459aa049a25f4542305f1;hp=df77454321765da6afb119e9f547be2f7d8fba25;hpb=30b5b5cceb167a87907d4cf122e77ce333fc5066;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index df77454..247b3b8 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -4,53 +4,43 @@ \section[TcIfaceSig]{Type checking of type signatures in interface files} \begin{code} -module TcIfaceSig ( tcInterfaceSigs ) where +module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where #include "HsVersions.h" -import HsSyn ( HsDecl(..), IfaceSig(..) ) +import HsSyn ( HsDecl(..), TyClDecl(..), HsTupCon(..) ) import TcMonad -import TcMonoType ( tcHsType, tcHsTypeKind, +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 - tcExtendTyVarScope - ) -import TcEnv ( ValueEnv, tcExtendTyVarEnv, - tcExtendGlobalValEnv, tcSetValueEnv, - tcLookupTyConByKey, tcLookupValueMaybe, - explicitLookupValue, badCon, badPrimOp + +import TcEnv ( TcEnv, tcExtendTyVarEnv, + tcExtendGlobalValEnv, tcSetEnv, + tcLookupGlobal_maybe, explicitLookupId, tcEnvIds ) -import TcType ( TcKind, kindToTcKind ) import RnHsSyn ( RenamedHsDecl ) import HsCore -import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) ) -import CallConv ( cCallConv ) -import Const ( Con(..), Literal(..) ) +import Literal ( Literal(..) ) import CoreSyn -import CoreUtils ( coreExprType ) +import CoreUtils ( exprType ) import CoreUnfold import CoreLint ( lintUnfolding ) -import WwLib ( mkWrapper ) -import PrimOp ( PrimOp(..) ) +import WorkWrap ( mkWrapper ) -import Id ( Id, mkImportedId, mkUserId, - isPrimitiveId_maybe, isDataConId_maybe - ) +import Id ( Id, mkId, mkVanillaId, isDataConWrapId_maybe ) +import MkId ( mkCCallOpId ) import IdInfo import DataCon ( dataConSig, dataConArgTys ) -import SpecEnv ( addToSpecEnv ) -import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp ) -import Var ( IdOrTyVar, mkTyVar, tyVarKind ) -import VarEnv -import Name ( Name, NamedThing(..) ) -import Unique ( rationalTyConKey ) -import TysWiredIn ( integerTy, stringTy ) +import Type ( mkTyVarTys, splitAlgTyConApp_maybe, unUsgTy ) +import Var ( mkTyVar, tyVarKind ) +import Name ( Name, isLocallyDefined ) +import Demand ( wwLazy ) import ErrUtils ( pprBagOfErrors ) -import Maybes ( maybeToBool, MaybeErr(..) ) import Outputable import Util ( zipWithEqual ) +import HscTypes ( TyThing(..) ) \end{code} Ultimately, type signatures in interfaces will have pragmatic @@ -61,133 +51,111 @@ As always, we do not have to worry about user-pragmas in interface signatures. \begin{code} -tcInterfaceSigs :: ValueEnv -- Envt to use when checking unfoldings +tcInterfaceSigs :: TcEnv -- Envt to use when checking unfoldings -> [RenamedHsDecl] -- Ignore non-sig-decls in these decls - -> TcM s [Id] + -> 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 + = listTc [ do_one name ty id_infos src_loc + | TyClD (IfaceSig name ty id_infos src_loc) <- decls] + where + in_scope_vars = filter isLocallyDefined (tcEnvIds unf_env) + + do_one name ty id_infos src_loc + = tcAddSrcLoc src_loc $ + tcAddErrCtxt (ifaceSigCtxt name) $ + tcHsType 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) \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 info_ins + = foldlTc tcPrag vanillaIdInfo info_ins where - tcPrag info (HsArity arity) = returnTc (arity `setArityInfo` info) - tcPrag info (HsUpdate upd) = returnTc (upd `setUpdateInfo` info) - tcPrag info (HsNoCafRefs) = returnTc (NoCafRefs `setCafInfo` info) - tcPrag info (HsCprInfo cpr_info) = returnTc (cpr_info `setCprInfo` info) - - tcPrag info (HsUnfold inline_prag maybe_expr) - = (case maybe_expr of - Just expr -> tcPragExpr unf_env name [] expr - Nothing -> returnNF_Tc Nothing - ) `thenNF_Tc` \ maybe_expr' -> + tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity) + tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs) + tcPrag info HsCprInfo = returnTc (info `setCprInfo` ReturnsCPR) + + tcPrag info (HsUnfold inline_prag expr) + = tcPragExpr unf_env name in_scope_vars expr `thenNF_Tc` \ 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_prag `setInlinePragInfo` info1 + Nothing -> noUnfolding + Just expr' -> mkTopUnfolding expr' + info1 = info `setUnfoldingInfo` unfold_info + info2 = info1 `setInlinePragInfo` inline_prag in returnTc info2 - tcPrag info (HsStrictness strict) - = tcStrictness unf_env ty info strict + tcPrag info (HsStrictness strict_info) + = returnTc (info `setStrictnessInfo` strict_info) - tcPrag info (HsSpecialise tyvars tys rhs) - = tcExtendTyVarScope tyvars $ \ tyvars' -> - mapAndUnzipTc tcHsTypeKind tys `thenTc` \ (kinds, tys') -> - -- Assume that the kinds match the kinds of the - -- type variables of the function; this is, after all, an - -- interface file generated by the compiler! - - tcPragExpr unf_env name tyvars' 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) + = tcWorkerInfo unf_env ty info nm \end{code} \begin{code} -tcStrictness unf_env ty info (HsStrictnessInfo (demands, bot_result) maybe_worker) - = tcWorker unf_env maybe_worker `thenNF_Tc` \ maybe_worker_id -> - -- We are relying here on cpr info always appearing before strictness info - -- fingers crossed .... - uniqSMToTcM (mkWrapper ty demands (cprInfo info)) - `thenNF_Tc` \ wrap_fn -> +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 - -- 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)) $ - setWorkerInfo (Just worker_id) $ - setInlinePragInfo IWantToBeINLINEd info - - Nothing -> info + -- 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 - has_worker = maybeToBool maybe_worker_id + Nothing -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info in - returnTc (StrictnessInfo demands bot_result `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) + returnTc info' where - maybe_worker_id = explicitLookupValue 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 arity, 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 \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 :: ValueEnv -> Name -> [IdOrTyVar] -> UfExpr Name -> NF_TcM s (Maybe CoreExpr) -tcPragExpr unf_env name in_scope_vars core_expr - = forkNF_Tc ( - recoverNF_Tc no_unfolding ( - tcSetValueEnv unf_env $ - tcCoreExpr core_expr `thenTc` \ core_expr' -> +tcPragExpr unf_env name in_scope_vars expr + = tcDelay unf_env doc $ + tcCoreExpr expr `thenTc` \ core_expr' -> -- Check for type consistency in the unfolding - tcGetSrcLoc `thenNF_Tc` \ src_loc -> - returnTc (lintUnfolding src_loc in_scope_vars core_expr') + 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) + where + doc = text "unfolding of" <+> ppr name + +tcDelay :: TcEnv -> 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! - no_unfolding = getErrsTc `thenNF_Tc` \ (warns,errs) -> - returnNF_Tc (pprTrace "tcUnfolding failed with:" - (hang (ppr name) 4 (pprBagOfErrors errs)) + bad_value = getErrsTc `thenNF_Tc` \ (warns,errs) -> + returnNF_Tc (pprTrace "Failed:" + (hang doc 4 (pprBagOfErrors errs)) Nothing) \end{code} @@ -198,12 +166,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 - = tcLookupValueMaybe name `thenNF_Tc` \ maybe_id -> + = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id -> case maybe_id of { - Just id -> returnTc id; - Nothing -> failWithTc (noDecl name) + Just (AnId id) -> returnTc id; + Nothing -> failWithTc (noDecl name) } noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name] @@ -212,10 +180,10 @@ 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) - = tcHsTypeKind ty `thenTc` \ (_, ty') -> + = tcHsType ty `thenTc` \ ty' -> -- It might not be of kind type returnTc (Type ty') @@ -223,19 +191,28 @@ tcCoreExpr (UfVar name) = tcVar name `thenTc` \ id -> returnTc (Var id) -tcCoreExpr (UfCon con args) - = tcUfCon con `thenTc` \ con' -> - mapTc tcCoreExpr args `thenTc` \ args' -> - returnTc (Con con' args') +tcCoreExpr (UfLit lit) + = returnTc (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) + = tcHsType ty `thenTc` \ ty' -> + returnTc (Lit (MachLitLit lit ty')) + +tcCoreExpr (UfCCall cc ty) + = tcHsType ty `thenTc` \ ty' -> + tcGetUnique `thenNF_Tc` \ u -> + returnTc (Var (mkCCallOpId u cc ty')) -tcCoreExpr (UfTuple name args) - = tcUfDataCon name `thenTc` \ con -> +tcCoreExpr (UfTuple (HsTupCon name _) args) + = tcVar name `thenTc` \ con_id -> mapTc tcCoreExpr args `thenTc` \ args' -> let -- Put the missing type arguments back in - con_args = map (Type . coreExprType) args' ++ args' + con_args = map (Type . unUsgTy . exprType) args' ++ args' in - returnTc (Con con con_args) + returnTc (mkApps (Var con_id) con_args) tcCoreExpr (UfLam bndr body) = tcCoreLamBndr bndr $ \ bndr' -> @@ -250,8 +227,8 @@ tcCoreExpr (UfApp fun arg) tcCoreExpr (UfCase scrut case_bndr alts) = tcCoreExpr scrut `thenTc` \ scrut' -> let - scrut_ty = coreExprType scrut' - case_bndr' = mkUserId case_bndr scrut_ty + scrut_ty = exprType scrut' + case_bndr' = mkVanillaId case_bndr scrut_ty in tcExtendGlobalValEnv [case_bndr'] $ mapTc (tcCoreAlt scrut_ty) alts `thenTc` \ alts' -> @@ -275,65 +252,18 @@ tcCoreExpr (UfNote note expr) = tcCoreExpr expr `thenTc` \ expr' -> case note of UfCoerce to_ty -> tcHsType to_ty `thenTc` \ to_ty' -> - returnTc (Note (Coerce to_ty' (coreExprType expr')) expr') + returnTc (Note (Coerce (unUsgTy to_ty') + (unUsgTy (exprType expr'))) expr') UfInlineCall -> returnTc (Note InlineCall expr') - UfSCC cc -> returnTc (Note (SCC cc) expr') - -tcCoreNote (UfSCC cc) = returnTc (SCC cc) -tcCoreNote UfInlineCall = returnTc InlineCall - - --- rationalTy isn't built in so, we have to construct it --- (the "ty" part of the incoming literal is simply bottom) -tcUfCon (UfLitCon (NoRepRational lit _)) - = tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon -> - let - rational_ty = mkSynTy rational_tycon [] - in - returnTc (Literal (NoRepRational lit rational_ty)) - --- Similarly for integers and strings, except that they are wired in -tcUfCon (UfLitCon (NoRepInteger lit _)) - = returnTc (Literal (NoRepInteger lit integerTy)) -tcUfCon (UfLitCon (NoRepStr lit _)) - = returnTc (Literal (NoRepStr lit stringTy)) - -tcUfCon (UfLitCon other_lit) - = returnTc (Literal other_lit) - --- The dreaded lit-lits are also similar, except here the type --- is read in explicitly rather than being implicit -tcUfCon (UfLitLitCon lit ty) - = tcHsType ty `thenTc` \ ty' -> - returnTc (Literal (MachLitLit lit ty')) - -tcUfCon (UfDataCon name) = tcUfDataCon name - -tcUfCon (UfPrimOp name) - = tcVar name `thenTc` \ op_id -> - case isPrimitiveId_maybe op_id of - Just op -> returnTc (PrimOp op) - Nothing -> failWithTc (badPrimOp name) - -tcUfCon (UfCCallOp str is_dyn casm gc) - = case is_dyn of - True -> - tcGetUnique `thenNF_Tc` \ u -> - returnTc (PrimOp (CCallOp (Right u) casm gc cCallConv)) - False -> returnTc (PrimOp (CCallOp (Left str) casm gc cCallConv)) - -tcUfDataCon name - = tcVar name `thenTc` \ con_id -> - case isDataConId_maybe con_id of - Just con -> returnTc (DataCon con) - Nothing -> failWithTc (badCon name) + UfInlineMe -> returnTc (Note InlineMe expr') + UfSCC cc -> returnTc (Note (SCC cc) expr') \end{code} \begin{code} tcCoreLamBndr (UfValBinder name ty) thing_inside = tcHsType ty `thenTc` \ ty' -> let - id = mkUserId name ty' + id = mkVanillaId name ty' in tcExtendGlobalValEnv [id] $ thing_inside id @@ -344,10 +274,16 @@ tcCoreLamBndr (UfTyBinder name kind) thing_inside in 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' -> let - id = mkUserId name ty' + id = mkVanillaId name ty' in tcExtendGlobalValEnv [id] $ thing_inside id @@ -355,7 +291,7 @@ tcCoreValBndr (UfValBinder name ty) thing_inside tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders = mapTc tcHsType tys `thenTc` \ tys' -> let - ids = zipWithEqual "tcCoreValBndr" mkUserId names tys' + ids = zipWithEqual "tcCoreValBndr" mkVanillaId names tys' in tcExtendGlobalValEnv ids $ thing_inside ids @@ -370,34 +306,36 @@ tcCoreAlt scrut_ty (UfDefault, names, rhs) tcCoreExpr rhs `thenTc` \ rhs' -> returnTc (DEFAULT, [], rhs') -tcCoreAlt scrut_ty (UfLitCon lit, names, rhs) +tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs) = ASSERT( null names ) tcCoreExpr rhs `thenTc` \ rhs' -> - returnTc (Literal lit, [], rhs') + returnTc (LitAlt lit, [], rhs') -tcCoreAlt scrut_ty (UfLitLitCon str ty, names, rhs) +tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs) = ASSERT( null names ) tcCoreExpr rhs `thenTc` \ rhs' -> tcHsType ty `thenTc` \ ty' -> - returnTc (Literal (MachLitLit str ty'), [], rhs') + 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 (UfDataCon con_name, names, rhs) +tcCoreAlt scrut_ty alt@(UfDataAlt con_name, names, rhs) = tcVar con_name `thenTc` \ con_id -> let - con = case isDataConId_maybe con_id of - Just con -> con - Nothing -> pprPanic "tcCoreAlt" (ppr con_id) + con = case isDataConWrapId_maybe con_id of + Just con -> con + Nothing -> pprPanic "tcCoreAlt" (ppr con_id) (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con - (tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty - 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 + (_, 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 arg_ids #ifdef DEBUG | length id_names /= length arg_tys @@ -406,13 +344,13 @@ tcCoreAlt scrut_ty (UfDataCon con_name, names, rhs) ppr arg_tys) | otherwise #endif - = zipWithEqual "tcCoreAlts" mkUserId id_names arg_tys + = zipWithEqual "tcCoreAlts" mkVanillaId 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 (DataCon con, ex_tyvars' ++ arg_ids, rhs') + returnTc (DataAlt con, ex_tyvars' ++ arg_ids, rhs') \end{code} \begin{code}