X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=93a90101575cfef04f905bb782e4cde01fa37d25;hp=4223af4da4faa794ba4ce5812fbdd4d83c77d21e;hb=a8427a4125e9b78e88a487eeabf018f1c6e8bc08;hpb=15cb792d18b1094e98c035dca6ecec5dad516056 diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 4223af4..93a9010 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -1,4 +1,5 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcBinds]{TcBinds} @@ -15,57 +16,37 @@ module TcBinds ( tcLocalBinds, tcTopBinds, import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcMonoExpr ) -import DynFlags ( dopt, DynFlags, - DynFlag(Opt_MonomorphismRestriction, Opt_MonoPatBinds, Opt_GlasgowExts) ) -import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..), - HsLocalBinds(..), HsValBinds(..), HsIPBinds(..), - LSig, Match(..), IPBind(..), Prag(..), - HsType(..), LHsType, HsExplicitForAll(..), hsLTyVarNames, - isVanillaLSig, sigName, placeHolderNames, isPragLSig, - LPat, GRHSs, MatchGroup(..), pprLHsBinds, mkHsCoerce, - collectHsBindBinders, collectPatBinders, pprPatBind, isBangHsBind - ) -import TcHsSyn ( zonkId ) +import DynFlags +import HsSyn +import TcHsSyn import TcRnMonad -import Inst ( newDictBndrs, newIPDict, instToId ) -import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2, - pprBinders, tcLookupId, - tcGetGlobalTyVars ) -import TcUnify ( tcInfer, tcSubExp, unifyTheta, - bleatEscapedTvs, sigCtxt ) -import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, - tcSimplifyRestricted, tcSimplifyIPs ) -import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) -import TcPat ( tcLetPat ) -import TcSimplify ( bindInstsOfLocalFuns ) -import TcMType ( newFlexiTyVarTy, zonkQuantifiedTyVar, zonkSigTyVar, - tcInstSigTyVars, tcInstSkolTyVars, tcInstType, - zonkTcType, zonkTcTypes, zonkTcTyVar ) -import TcType ( TcType, TcTyVar, TcThetaType, - SkolemInfo(SigSkol), UserTypeCtxt(FunSigCtxt), - TcTauType, TcSigmaType, isUnboxedTupleType, - mkTyVarTy, mkForAllTys, mkFunTys, exactTyVarsOfType, - mkForAllTy, isUnLiftedType, tcGetTyVar, - mkTyVarTys, tidyOpenTyVar ) -import {- Kind parts of -} Type ( argTypeKind ) -import VarEnv ( TyVarEnv, emptyVarEnv, lookupVarEnv, extendVarEnv ) -import TysPrim ( alphaTyVar ) -import Id ( Id, mkLocalId, mkVanillaGlobal ) -import IdInfo ( vanillaIdInfo ) -import Var ( TyVar, idType, idName ) -import Name ( Name ) +import Inst +import TcEnv +import TcUnify +import TcSimplify +import TcHsType +import TcPat +import TcMType +import TcType +import {- Kind parts of -} Type +import VarEnv +import TysPrim +import Id +import IdInfo +import Var ( TyVar ) +import Name import NameSet import NameEnv import VarSet -import SrcLoc ( Located(..), unLoc, getLoc ) +import SrcLoc import Bag -import ErrUtils ( Message ) -import Digraph ( SCC(..), stronglyConnComp ) -import Maybes ( expectJust, isJust, isNothing, orElse ) -import Util ( singleton ) -import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, - RecFlag(..), isNonRec, InlineSpec, defaultInlineSpec ) +import ErrUtils +import Digraph +import Maybes +import List +import Util +import BasicTypes import Outputable \end{code} @@ -181,9 +162,9 @@ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside -- Extend the envt right away with all -- the Ids declared with type signatures - ; gla_exts <- doptM Opt_GlasgowExts + ; poly_rec <- doptM Opt_RelaxedPolyRec ; (binds', thing) <- tcExtendIdEnv poly_ids $ - tc_val_binds gla_exts top_lvl sig_fn prag_fn + tc_val_binds poly_rec top_lvl sig_fn prag_fn binds thing_inside ; return (ValBindsOut binds' sigs, thing) } @@ -195,14 +176,14 @@ tc_val_binds :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun -- Typecheck a whole lot of value bindings, -- one strongly-connected component at a time -tc_val_binds gla_exts top_lvl sig_fn prag_fn [] thing_inside +tc_val_binds poly_rec top_lvl sig_fn prag_fn [] thing_inside = do { thing <- thing_inside ; return ([], thing) } -tc_val_binds gla_exts top_lvl sig_fn prag_fn (group : groups) thing_inside +tc_val_binds poly_rec top_lvl sig_fn prag_fn (group : groups) thing_inside = do { (group', (groups', thing)) - <- tc_group gla_exts top_lvl sig_fn prag_fn group $ - tc_val_binds gla_exts top_lvl sig_fn prag_fn groups thing_inside + <- tc_group poly_rec top_lvl sig_fn prag_fn group $ + tc_val_binds poly_rec top_lvl sig_fn prag_fn groups thing_inside ; return (group' ++ groups', thing) } ------------------------ @@ -214,15 +195,15 @@ tc_group :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun -- We get a list of groups back, because there may -- be specialisations etc as well -tc_group gla_exts top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside +tc_group poly_rec top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside -- A single non-recursive binding -- We want to keep non-recursive things non-recursive -- so that we desugar unlifted bindings correctly = do { (binds, thing) <- tc_haskell98 top_lvl sig_fn prag_fn NonRecursive binds thing_inside ; return ([(NonRecursive, b) | b <- binds], thing) } -tc_group gla_exts top_lvl sig_fn prag_fn (Recursive, binds) thing_inside - | not gla_exts -- Recursive group, normal Haskell 98 route +tc_group poly_rec top_lvl sig_fn prag_fn (Recursive, binds) thing_inside + | not poly_rec -- Recursive group, normal Haskell 98 route = do { (binds1, thing) <- tc_haskell98 top_lvl sig_fn prag_fn Recursive binds thing_inside ; return ([(Recursive, unionManyBags binds1)], thing) } @@ -330,6 +311,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds -- TYPECHECK THE BINDINGS ; ((binds', mono_bind_infos), lie_req) <- getLIE (tcMonoBinds bind_list sig_fn rec_tc) + ; traceTc (text "temp" <+> (ppr binds' $$ ppr lie_req)) -- CHECK FOR UNLIFTED BINDINGS -- These must be non-recursive etc, and are not generalised @@ -349,24 +331,19 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds else do -- The normal lifted case: GENERALISE { dflags <- getDOpts - ; (tyvars_to_gen, dict_binds, dict_ids) + ; (tyvars_to_gen, dicts, dict_binds) <- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $ generalise dflags top_lvl bind_list sig_fn mono_bind_infos lie_req - -- FINALISE THE QUANTIFIED TYPE VARIABLES - -- The quantified type variables often include meta type variables - -- we want to freeze them into ordinary type variables, and - -- default their kind (e.g. from OpenTypeKind to TypeKind) - ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen - -- BUILD THE POLYMORPHIC RESULT IDs - ; exports <- mapM (mkExport prag_fn tyvars_to_gen' (map idType dict_ids)) + ; let dict_ids = map instToId dicts + ; exports <- mapM (mkExport top_lvl prag_fn tyvars_to_gen (map idType dict_ids)) mono_bind_infos ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports] ; traceTc (text "binding:" <+> ppr (poly_ids `zip` map idType poly_ids)) - ; let abs_bind = L loc $ AbsBinds tyvars_to_gen' + ; let abs_bind = L loc $ AbsBinds tyvars_to_gen dict_ids exports (dict_binds `unionBags` binds') @@ -375,8 +352,9 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds -------------- -mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo - -> TcM ([TyVar], Id, Id, [Prag]) +mkExport :: TopLevelFlag -> TcPragFun -> [TyVar] -> [TcType] + -> MonoBindInfo + -> TcM ([TyVar], Id, Id, [LPrag]) -- mkExport generates exports with -- zonked type variables, -- zonked poly_ids @@ -388,8 +366,10 @@ mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo -- Pre-condition: the inferred_tvs are already zonked -mkExport prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id) - = do { (tvs, poly_id) <- mk_poly_id mb_sig +mkExport top_lvl prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id) + = do { warn_missing_sigs <- doptM Opt_WarnMissingSigs + ; let warn = isTopLevel top_lvl && warn_missing_sigs + ; (tvs, poly_id) <- mk_poly_id warn mb_sig ; poly_id' <- zonkId poly_id ; prags <- tcPrags poly_id' (prag_fn poly_name) @@ -399,9 +379,10 @@ mkExport prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id) where poly_ty = mkForAllTys inferred_tvs (mkFunTys dict_tys (idType mono_id)) - mk_poly_id Nothing = return (inferred_tvs, mkLocalId poly_name poly_ty) - mk_poly_id (Just sig) = do { tvs <- mapM zonk_tv (sig_tvs sig) - ; return (tvs, sig_id sig) } + mk_poly_id warn Nothing = do { missingSigWarn warn poly_name poly_ty + ; return (inferred_tvs, mkLocalId poly_name poly_ty) } + mk_poly_id warn (Just sig) = do { tvs <- mapM zonk_tv (sig_tvs sig) + ; return (tvs, sig_id sig) } zonk_tv tv = do { ty <- zonkTcTyVar tv; return (tcGetTyVar "mkExport" ty) } @@ -416,12 +397,11 @@ mkPragFun sigs = \n -> lookupNameEnv env n `orElse` [] env = foldl add emptyNameEnv prs add env (n,p) = extendNameEnv_Acc (:) singleton env n p -tcPrags :: Id -> [LSig Name] -> TcM [Prag] -tcPrags poly_id prags = mapM tc_prag prags +tcPrags :: Id -> [LSig Name] -> TcM [LPrag] +tcPrags poly_id prags = mapM (wrapLocM tc_prag) prags where - tc_prag (L loc prag) = setSrcSpan loc $ - addErrCtxt (pragSigCtxt prag) $ - tcPrag poly_id prag + tc_prag prag = addErrCtxt (pragSigCtxt prag) $ + tcPrag poly_id prag pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag) @@ -439,7 +419,7 @@ tcSpecPrag poly_id hs_ty inl ; (co_fn, lie) <- getLIE (tcSubExp (idType poly_id) spec_ty) ; extendLIEs lie ; let const_dicts = map instToId lie - ; return (SpecPrag (mkHsCoerce co_fn (HsVar poly_id)) spec_ty const_dicts inl) } + ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty const_dicts inl) } -- Most of the work of specialisation is done by -- the desugarer, guided by the SpecPrag @@ -531,7 +511,7 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, -- e.g. f = \(x::forall a. a->a) -> -- We want to infer a higher-rank type for f setSrcSpan b_loc $ - do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name matches) + do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name inf matches) -- Check for an unboxed tuple type -- f = (# True, False #) @@ -546,7 +526,7 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, ; let mono_id = mkLocalId mono_name zonked_rhs_ty ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf, fun_matches = matches', bind_fvs = fvs, - fun_co_fn = co_fn })), + fun_co_fn = co_fn, fun_tick = Nothing })), [(name, Nothing, mono_id)]) } tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, @@ -566,11 +546,12 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, | (name, tv) <- sig_scoped tc_sig `zip` sig_tvs tc_sig ] ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $ - tcMatchesFun mono_name matches mono_ty + tcMatchesFun mono_name inf matches mono_ty ; let fun_bind' = FunBind { fun_id = L nm_loc mono_id, fun_infix = inf, fun_matches = matches', - bind_fvs = placeHolderNames, fun_co_fn = co_fn } + bind_fvs = placeHolderNames, fun_co_fn = co_fn, + fun_tick = Nothing } ; return (unitBag (L b_loc fun_bind'), [(name, Just tc_sig, mono_id)]) } @@ -672,10 +653,11 @@ tcLhs sig_fn other_bind = pprPanic "tcLhs" (ppr other_bind) ------------------- tcRhs :: TcMonoBind -> TcM (HsBind TcId) tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches) - = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) matches - (idType mono_id) + = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) inf + matches (idType mono_id) ; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches', - bind_fvs = placeHolderNames, fun_co_fn = co_fn }) } + bind_fvs = placeHolderNames, fun_co_fn = co_fn, + fun_tick = Nothing }) } tcRhs bind@(TcPatBind _ pat' grhss pat_ty) = do { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ @@ -704,10 +686,13 @@ getMonoBindInfo tc_binds generalise :: DynFlags -> TopLevelFlag -> [LHsBind Name] -> TcSigFun -> [MonoBindInfo] -> [Inst] - -> TcM ([TcTyVar], TcDictBinds, [TcId]) + -> TcM ([TyVar], [Inst], TcDictBinds) +-- The returned [TyVar] are all ready to quantify + generalise dflags top_lvl bind_list sig_fn mono_infos lie_req | isMonoGroup dflags bind_list - = do { extendLIEs lie_req; return ([], emptyBag, []) } + = do { extendLIEs lie_req + ; return ([], [], emptyBag) } | isRestrictedGroup dflags bind_list sig_fn -- RESTRICTED CASE = -- Check signature contexts are empty @@ -722,27 +707,28 @@ generalise dflags top_lvl bind_list sig_fn mono_infos lie_req -- Check that signature type variables are OK ; final_qtvs <- checkSigsTyVars qtvs sigs - ; return (final_qtvs, binds, []) } + ; return (final_qtvs, [], binds) } | null sigs -- UNRESTRICTED CASE, NO TYPE SIGS = tcSimplifyInfer doc tau_tvs lie_req | otherwise -- UNRESTRICTED CASE, WITH TYPE SIGS - = do { sig_lie <- unifyCtxts sigs -- sigs is non-empty + = do { sig_lie <- unifyCtxts sigs -- sigs is non-empty; sig_lie is zonked ; let -- The "sig_avails" is the stuff available. We get that from -- the context of the type signature, BUT ALSO the lie_avail -- so that polymorphic recursion works right (see Note [Polymorphic recursion]) local_meths = [mkMethInst sig mono_id | (_, Just sig, mono_id) <- mono_infos] sig_avails = sig_lie ++ local_meths + loc = sig_loc (head sigs) -- Check that the needed dicts can be -- expressed in terms of the signature ones - ; (forall_tvs, dict_binds) <- tcSimplifyInferCheck doc tau_tvs sig_avails lie_req + ; (qtvs, binds) <- tcSimplifyInferCheck loc tau_tvs sig_avails lie_req -- Check that signature type variables are OK - ; final_qtvs <- checkSigsTyVars forall_tvs sigs + ; final_qtvs <- checkSigsTyVars qtvs sigs - ; returnM (final_qtvs, dict_binds, map instToId sig_lie) } + ; returnM (final_qtvs, sig_lie, binds) } where bndrs = bndrNames mono_infos sigs = [sig | (_, Just sig, _) <- mono_infos] @@ -754,7 +740,8 @@ generalise dflags top_lvl bind_list sig_fn mono_infos lie_req mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_theta = theta, sig_loc = loc }) mono_id - = Method mono_id poly_id (mkTyVarTys tvs) theta loc + = Method {tci_id = mono_id, tci_oid = poly_id, tci_tys = mkTyVarTys tvs, + tci_theta = theta, tci_loc = loc} \end{code} unifyCtxts checks that all the signature contexts are the same @@ -771,14 +758,16 @@ might not otherwise be related. This is a rather subtle issue. \begin{code} unifyCtxts :: [TcSigInfo] -> TcM [Inst] +-- Post-condition: the returned Insts are full zonked unifyCtxts (sig1 : sigs) -- Argument is always non-empty = do { mapM unify_ctxt sigs - ; newDictBndrs (sig_loc sig1) (sig_theta sig1) } + ; theta <- zonkTcThetaType (sig_theta sig1) + ; newDictBndrs (sig_loc sig1) theta } where theta1 = sig_theta sig1 unify_ctxt :: TcSigInfo -> TcM () unify_ctxt sig@(TcSigInfo { sig_theta = theta }) - = setSrcSpan (instLocSrcSpan (sig_loc sig)) $ + = setSrcSpan (instLocSpan (sig_loc sig)) $ addErrCtxt (sigContextsCtxt sig1 sig) $ unifyTheta theta1 theta @@ -841,7 +830,7 @@ checkDistinctTyVars sig_tvs <+> quotes (ppr tidy_tv2) ; failWithTcM (env2, msg) } where -\end{code} +\end{code} @getTyVarsToGen@ decides what type variables to generalise over. @@ -973,13 +962,12 @@ mkTcSigFun :: [LSig Name] -> TcSigFun -- Precondition: no duplicates mkTcSigFun sigs = lookupNameEnv env where - env = mkNameEnv [(name, scoped_tyvars hs_ty) - | L span (TypeSig (L _ name) (L _ hs_ty)) <- sigs] - scoped_tyvars (HsForAllTy Explicit tvs _ _) = hsLTyVarNames tvs - scoped_tyvars other = [] + env = mkNameEnv [(name, hsExplicitTvs lhs_ty) + | L span (TypeSig (L _ name) lhs_ty) <- sigs] -- The scoped names are the ones explicitly mentioned -- in the HsForAll. (There may be more in sigma_ty, because -- of nested type synonyms. See Note [Scoped] with TcSigInfo.) + -- See Note [Only scoped tyvars are in the TyVarEnv] --------------- data TcSigInfo @@ -998,6 +986,19 @@ data TcSigInfo sig_loc :: InstLoc -- The location of the signature } + +-- Note [Only scoped tyvars are in the TyVarEnv] +-- We are careful to keep only the *lexically scoped* type variables in +-- the type environment. Why? After all, the renamer has ensured +-- that only legal occurrences occur, so we could put all type variables +-- into the type env. +-- +-- But we want to check that two distinct lexically scoped type variables +-- do not map to the same internal type variable. So we need to know which +-- the lexically-scoped ones are... and at the moment we do that by putting +-- only the lexically scoped ones into the environment. + + -- Note [Scoped] -- There may be more instantiated type variables than scoped -- ones. For example: @@ -1010,7 +1011,7 @@ data TcSigInfo -- and remember the names from the original HsForAllTy in sig_scoped -- Note [Instantiate sig] --- It's vital to instantiate a type signature with fresh variable. +-- It's vital to instantiate a type signature with fresh variables. -- For example: -- type S = forall a. a->a -- f,g :: S @@ -1046,7 +1047,7 @@ tcInstSig :: Bool -> Name -> [Name] -> TcM TcSigInfo -- Instantiate the signature, with either skolems or meta-type variables -- depending on the use_skols boolean. This variable is set True -- when we are typechecking a single function binding; and False for --- pattern bindigs and a group of several function bindings. +-- pattern bindings and a group of several function bindings. -- Reason: in the latter cases, the "skolems" can be unified together, -- so they aren't properly rigid in the type-refinement sense. -- NB: unless we are doing H98, each function with a sig will be done @@ -1065,8 +1066,7 @@ tcInstSig use_skols name scoped_names = do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into -- scope when starting the binding group ; let skol_info = SigSkol (FunSigCtxt name) - inst_tyvars | use_skols = tcInstSkolTyVars skol_info - | otherwise = tcInstSigTyVars skol_info + inst_tyvars = tcInstSigTyVars use_skols skol_info ; (tvs, theta, tau) <- tcInstType inst_tyvars (idType poly_id) ; loc <- getInstLoc (SigOrigin skol_info) ; return (TcSigInfo { sig_id = poly_id, @@ -1148,4 +1148,13 @@ restrictedBindCtxtErr binder_names genCtxt binder_names = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names + +missingSigWarn False name ty = return () +missingSigWarn True name ty + = do { env0 <- tcInitTidyEnv + ; let (env1, tidy_ty) = tidyOpenType env0 ty + ; addWarnTcM (env1, mk_msg tidy_ty) } + where + mk_msg ty = vcat [ptext SLIT("Definition but no type signature for") <+> quotes (ppr name), + sep [ptext SLIT("Inferred type:") <+> ppr name <+> dcolon <+> ppr ty]] \end{code}