X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=395744d7c0bdc6f605bf78cb5ade89b37ec1bf44;hb=508a505e9853984bfdaa3ad855ae3fcbc6d31787;hp=f9bcc6db0bfa5ba4f8fa8beaf1cfc41e390f4a2d;hpb=23f40f0e9be6d4aa5cf9ea31d73f4013f8e7b4bd;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index f9bcc6d..395744d 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -4,16 +4,17 @@ \section[TcBinds]{TcBinds} \begin{code} -module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where +module TcBinds ( tcBindsAndThen, tcTopBinds, tcHsBootSigs, tcMonoBinds, tcSpecSigs ) where #include "HsVersions.h" import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcCheckSigma, tcCheckRho ) -import CmdLineOpts ( DynFlag(Opt_NoMonomorphismRestriction) ) +import CmdLineOpts ( DynFlag(Opt_MonomorphismRestriction) ) import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, Sig(..), - LSig, Match(..), HsBindGroup(..), IPBind(..), + LSig, Match(..), HsBindGroup(..), IPBind(..), + HsType(..), hsLTyVarNames, isVanillaLSig, LPat, GRHSs, MatchGroup(..), emptyLHsBinds, isEmptyLHsBinds, collectHsBindBinders, collectPatBinders, pprPatBind ) @@ -21,16 +22,16 @@ import TcHsSyn ( TcId, TcDictBinds, zonkId, mkHsLet ) import TcRnMonad import Inst ( InstOrigin(..), newDictsAtLoc, newIPDict, instToId ) -import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, newLocalName, tcLookupLocalIds ) +import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2, newLocalName, tcLookupLocalIds ) import TcUnify ( Expected(..), tcInfer, checkSigTyVars, sigCtxt ) import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts, tcSimplifyIPs ) import TcHsType ( tcHsSigType, UserTypeCtxt(..), tcAddLetBoundTyVars, - TcSigInfo(..), TcSigFun, mkTcSig, lookupSig + TcSigInfo(..), TcSigFun, lookupSig ) import TcPat ( tcPat, PatCtxt(..) ) import TcSimplify ( bindInstsOfLocalFuns ) -import TcMType ( newTyFlexiVarTy, tcSkolType, zonkQuantifiedTyVar ) +import TcMType ( newTyFlexiVarTy, tcSkolType, zonkQuantifiedTyVar, zonkTcTypes ) import TcType ( TcTyVar, SkolemInfo(SigSkol), TcTauType, TcSigmaType, TvSubstEnv, mkTvSubst, substTheta, substTy, @@ -38,18 +39,18 @@ import TcType ( TcTyVar, SkolemInfo(SigSkol), mkForAllTy, isUnLiftedType, tcGetTyVar_maybe, mkTyVarTys ) import Unify ( tcMatchPreds ) -import Kind ( argTypeKind, isUnliftedTypeKind ) +import Kind ( argTypeKind ) import VarEnv ( lookupVarEnv ) import TysPrim ( alphaTyVar ) import Id ( mkLocalId, mkSpecPragmaId, setInlinePragma ) import Var ( idType, idName ) import Name ( Name ) import NameSet -import Var ( tyVarKind ) import VarSet import SrcLoc ( Located(..), unLoc, noLoc, getLoc ) import Bag import Util ( isIn ) +import Maybes ( orElse ) import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isRec, isNotTopLevel, isAlwaysActive ) import FiniteMap ( listToFM, lookupFM ) @@ -94,15 +95,28 @@ tcTopBinds :: [HsBindGroup Name] -> TcM (LHsBinds TcId, TcLclEnv) -- want. The bit we care about is the local bindings -- and the free type variables thereof tcTopBinds binds - = tc_binds_and_then TopLevel glue binds $ - getLclEnv `thenM` \ env -> - returnM (emptyLHsBinds, env) + = tc_binds_and_then TopLevel glue binds $ + do { env <- getLclEnv + ; return (emptyLHsBinds, env) } where -- The top level bindings are flattened into a giant -- implicitly-mutually-recursive MonoBinds glue (HsBindGroup binds1 _ _) (binds2, env) = (binds1 `unionBags` binds2, env) + glue (HsIPBinds _) _ = panic "Top-level HsIpBinds" -- Can't have a HsIPBinds at top level +tcHsBootSigs :: [HsBindGroup Name] -> TcM (LHsBinds TcId, TcLclEnv) +-- A hs-boot file has only one BindGroup, and it only has type +-- signatures in it. The renamer checked all this +tcHsBootSigs [HsBindGroup _ sigs _] + = do { ids <- mapM (addLocM tc_sig) (filter isVanillaLSig sigs) + ; tcExtendIdEnv ids $ do + { env <- getLclEnv + ; return (emptyLHsBinds, env) }} + where + tc_sig (Sig (L _ name) ty) + = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty + ; return (mkLocalId name sigma_ty) } tcBindsAndThen :: (HsBindGroup TcId -> thing -> thing) -- Combinator @@ -237,11 +251,12 @@ tcBindWithSigs :: TopLevelFlag -> [LSig Name] -> RecFlag -> TcM (LHsBinds TcId, [TcId]) + -- The returned TcIds are guaranteed zonked tcBindWithSigs top_lvl mbind sigs is_rec = do { -- TYPECHECK THE SIGNATURES tc_ty_sigs <- recoverM (returnM []) $ - tcTySigs [sig | sig@(L _(Sig name _)) <- sigs] + tcTySigs (filter isVanillaLSig sigs) ; let lookup_sig = lookupSig tc_ty_sigs -- SET UP THE MAIN RECOVERY; take advantage of any type sigs @@ -254,8 +269,23 @@ tcBindWithSigs top_lvl mbind sigs is_rec = do ; ((mbind', mono_bind_infos), lie_req) <- getLIE (tcMonoBinds mbind lookup_sig is_rec) - -- GENERALISE - ; is_unres <- isUnRestrictedGroup mbind tc_ty_sigs + -- CHECK FOR UNLIFTED BINDINGS + -- These must be non-recursive etc, and are not generalised + -- They desugar to a case expression in the end + ; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos) + ; if any isUnLiftedType zonked_mono_tys then + do { -- Unlifted bindings + checkUnliftedBinds top_lvl is_rec mbind + ; extendLIEs lie_req + ; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys + mk_export (name, Nothing, mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id) + mk_export (name, Just sig, mono_id) mono_ty = ([], sig_id sig, mono_id) + + ; return ( unitBag $ noLoc $ AbsBinds [] [] exports emptyNameSet mbind', + [poly_id | (_, poly_id, _) <- exports]) } -- Guaranteed zonked + + else do -- The normal lifted case: GENERALISE + { is_unres <- isUnRestrictedGroup mbind tc_ty_sigs ; (tyvars_to_gen, dict_binds, dict_ids) <- setSrcSpan (getLoc (head (bagToList mbind))) $ -- TODO: location a bit awkward, but the mbinds have been @@ -303,28 +333,16 @@ tcBindWithSigs top_lvl mbind sigs is_rec = do ; traceTc (text "binding:" <+> ppr ((dict_ids, dict_binds), exports, map idType zonked_poly_ids)) - -- Check for an unlifted, non-overloaded group - -- In that case we must make extra checks - ; if any (isUnLiftedType . idType) zonked_poly_ids - then -- Some bindings are unlifted - do { checkUnliftedBinds top_lvl is_rec tyvars_to_gen' mbind - ; return ( - unitBag $ noLoc $ - AbsBinds [] [] exports inlines mbind', - -- Do not generate even any x=y bindings - zonked_poly_ids )} - - else -- The normal case - return ( + ; return ( unitBag $ noLoc $ AbsBinds tyvars_to_gen' - dict_ids - exports - inlines - (dict_binds `unionBags` mbind'), + dict_ids + exports + inlines + (dict_binds `unionBags` mbind'), zonked_poly_ids ) - } } + } } } -- If typechecking the binds fails, then return with each -- signature-less binder given type (forall a.a), to minimise @@ -348,26 +366,15 @@ attachInlinePhase inline_phases bndr -- Check that non-overloaded unlifted bindings are -- a) non-recursive, -- b) not top level, --- c) non-polymorphic --- d) not a multiple-binding group (more or less implied by (a)) - -checkUnliftedBinds top_lvl is_rec tyvars_to_gen mbind - = ASSERT( not (any (isUnliftedTypeKind . tyVarKind) tyvars_to_gen) ) - -- The instCantBeGeneralised stuff in tcSimplify should have - -- already raised an error if we're trying to generalise an - -- unboxed tyvar (NB: unboxed tyvars are always introduced - -- along with a class constraint) and it's better done there - -- because we have more precise origin information. - -- That's why we just use an ASSERT here. - - checkTc (isNotTopLevel top_lvl) +-- c) not a multiple-binding group (more or less implied by (a)) + +checkUnliftedBinds top_lvl is_rec mbind + = checkTc (isNotTopLevel top_lvl) (unliftedBindErr "Top-level" mbind) `thenM_` checkTc (isNonRec is_rec) (unliftedBindErr "Recursive" mbind) `thenM_` checkTc (isSingletonBag mbind) - (unliftedBindErr "Multiple" mbind) `thenM_` - checkTc (null tyvars_to_gen) - (unliftedBindErr "Polymorphic" mbind) + (unliftedBindErr "Multiple" mbind) \end{code} @@ -441,22 +448,26 @@ tcMonoBinds :: LHsBinds Name -> TcSigFun -> RecFlag -> TcM (LHsBinds TcId, [MonoBindInfo]) -type MonoBindInfo = (Name, Maybe TcSigInfo, TcId) - -- Type signature (if any), and - -- the monomorphic bound things - -bndrNames :: [MonoBindInfo] -> [Name] -bndrNames mbi = [n | (n,_,_) <- mbi] - -getMonoType :: MonoBindInfo -> TcTauType -getMonoType (_,_,mono_id) = idType mono_id - tcMonoBinds binds lookup_sig is_rec = do { tc_binds <- mapBagM (wrapLocM (tcLhs lookup_sig)) binds - ; let mono_info = getMonoBindInfo tc_binds - ; binds' <- tcExtendIdEnv2 (rhsEnvExtension mono_info) $ + + -- Bring (a) the scoped type variables, and (b) the Ids, into scope for the RHSs + -- For (a) it's ok to bring them all into scope at once, even + -- though each type sig should scope only over its own RHS, + -- because the renamer has sorted all that out. + ; let mono_info = getMonoBindInfo tc_binds + rhs_tvs = [ (name, mkTyVarTy tv) + | (_, Just sig, _) <- mono_info, + (name, tv) <- sig_scoped sig `zip` sig_tvs sig ] + rhs_id_env = map mk mono_info -- A binding for each term variable + + ; binds' <- tcExtendTyVarEnv2 rhs_tvs $ + tcExtendIdEnv2 rhs_id_env $ mapBagM (wrapLocM tcRhs) tc_binds ; return (binds', mono_info) } + where + mk (name, Just sig, _) = (name, sig_id sig) -- Use the type sig if there is one + mk (name, Nothing, mono_id) = (name, mono_id) -- otherwise use a monomorphic version ------------------------ -- tcLhs typechecks the LHS of the bindings, to construct the environment in which @@ -478,6 +489,16 @@ data TcMonoBind -- Half completed; LHS done, RHS not done = TcFunBind MonoBindInfo (Located TcId) Bool (MatchGroup Name) | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType +type MonoBindInfo = (Name, Maybe TcSigInfo, TcId) + -- Type signature (if any), and + -- the monomorphic bound things + +bndrNames :: [MonoBindInfo] -> [Name] +bndrNames mbi = [n | (n,_,_) <- mbi] + +getMonoType :: MonoBindInfo -> TcTauType +getMonoType (_,_,mono_id) = idType mono_id + tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind tcLhs lookup_sig (FunBind (L nm_loc name) inf matches) = do { let mb_sig = lookup_sig name @@ -511,7 +532,7 @@ tcLhs lookup_sig bind@(PatBind pat grhss _) ------------------- tcRhs :: TcMonoBind -> TcM (HsBind TcId) -tcRhs (TcFunBind _ fun'@(L _ mono_id) inf matches) +tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches) = do { matches' <- tcMatchesFun (idName mono_id) matches (Check (idType mono_id)) ; return (FunBind fun' inf matches') } @@ -529,15 +550,6 @@ getMonoBindInfo tc_binds where get_info (TcFunBind info _ _ _) rest = info : rest get_info (TcPatBind infos _ _ _) rest = infos ++ rest - ---------------------- -rhsEnvExtension :: [MonoBindInfo] -> [(Name, TcId)] --- Environment for RHS of definitions: use type sig if there is one -rhsEnvExtension mono_info - = map mk mono_info - where - mk (name, Just sig, _) = (name, sig_id sig) - mk (name, Nothing, mono_id) = (name, mono_id) \end{code} @@ -554,42 +566,55 @@ tcTySigs :: [LSig Name] -> TcM [TcSigInfo] -- all the right hand sides agree a common vocabulary for their type -- constraints tcTySigs [] = return [] -tcTySigs (L span (Sig (L _ name) ty) : sigs) - = do { -- Typecheck the first signature - ; sigma1 <- setSrcSpan span $ - tcHsSigType (FunSigCtxt name) ty - ; let id1 = mkLocalId name sigma1 - ; tc_sig1 <- mkTcSig id1 - ; tc_sigs <- mapM (tcTySig tc_sig1) sigs - ; return (tc_sig1 : tc_sigs) } +tcTySigs sigs + = do { (tc_sig1 : tc_sigs) <- mappM tcTySig sigs + ; tc_sigs' <- mapM (checkSigCtxt tc_sig1) tc_sigs + ; return (tc_sig1 : tc_sigs') } -tcTySig sig1 (L span (Sig (L _ name) ty)) +tcTySig :: LSig Name -> TcM TcSigInfo +tcTySig (L span (Sig (L _ name) ty)) = setSrcSpan span $ do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty + ; let rigid_info = SigSkol name + poly_id = mkLocalId name sigma_ty + + -- 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.) + scoped_names = case ty of + L _ (HsForAllTy _ tvs _ _) -> hsLTyVarNames tvs + other -> [] + ; (tvs, theta, tau) <- tcSkolType rigid_info sigma_ty - ; let poly_id = mkLocalId name sigma_ty - bale_out = failWithTc $ - sigContextsErr (sig_id sig1) name sigma_ty + ; loc <- getInstLoc (SigOrigin rigid_info) + ; return (TcSigInfo { sig_id = poly_id, sig_scoped = scoped_names, + sig_tvs = tvs, sig_theta = theta, sig_tau = tau, + sig_loc = loc }) } - -- Try to match the context of this signature with +checkSigCtxt :: TcSigInfo -> TcSigInfo -> TcM TcSigInfo +checkSigCtxt sig1 sig@(TcSigInfo { sig_tvs = tvs, sig_theta = theta, sig_tau = tau }) + = -- Try to match the context of this signature with -- that of the first signature - ; case tcMatchPreds tvs (sig_theta sig1) theta of { - Nothing -> bale_out - ; Just tenv -> do - ; case check_tvs tenv tvs of - Nothing -> bale_out - Just tvs' -> do - - { let subst = mkTvSubst tenv - theta' = substTheta subst theta - tau' = substTy subst tau - ; loc <- getInstLoc (SigOrigin rigid_info) - ; return (TcSigInfo { sig_id = poly_id, sig_tvs = tvs', - sig_theta = theta', sig_tau = tau', - sig_loc = loc }) }}} + case tcMatchPreds (sig_tvs sig) (sig_theta sig) (sig_theta sig1) of { + Nothing -> bale_out ; + Just tenv -> + + case check_tvs tenv tvs of { + Nothing -> bale_out ; + Just tvs' -> + + let + subst = mkTvSubst tenv + in + return (sig { sig_tvs = tvs', + sig_theta = substTheta subst theta, + sig_tau = substTy subst tau }) }} + where - rigid_info = SigSkol name + bale_out = setSrcSpan (instLocSrcSpan (sig_loc sig)) $ + failWithTc $ + sigContextsErr (sig_id sig1) (sig_id sig) -- Rather tedious check that the type variables -- have been matched only with another type variable, @@ -600,15 +625,12 @@ tcTySig sig1 (L span (Sig (L _ name) ty)) check_tvs :: TvSubstEnv -> [TcTyVar] -> Maybe [TcTyVar] check_tvs tenv [] = Just [] check_tvs tenv (tv:tvs) - | Just ty <- lookupVarEnv tenv tv - = do { tv' <- tcGetTyVar_maybe ty + = do { let ty = lookupVarEnv tenv tv `orElse` mkTyVarTy tv + ; tv' <- tcGetTyVar_maybe ty ; tvs' <- check_tvs tenv tvs ; if tv' `elem` tvs' then Nothing else Just (tv':tvs') } - | otherwise - = do { tvs' <- check_tvs tenv tvs - ; Just (tv:tvs') } \end{code} \begin{code} @@ -727,8 +749,8 @@ find which tyvars are constrained. \begin{code} isUnRestrictedGroup :: LHsBinds Name -> [TcSigInfo] -> TcM Bool isUnRestrictedGroup binds sigs - = do { no_MR <- doptM Opt_NoMonomorphismRestriction - ; return (no_MR || all_unrestricted) } + = do { mono_restriction <- doptM Opt_MonomorphismRestriction + ; return (not mono_restriction || all_unrestricted) } where all_unrestricted = all (unrestricted . unLoc) (bagToList binds) tysig_names = map (idName . sig_id) sigs @@ -841,10 +863,10 @@ valSpecSigCtxt v ty nest 4 (ppr v <+> dcolon <+> ppr ty)] ----------------------------------------------- -sigContextsErr id1 name ty +sigContextsErr id1 id2 = vcat [ptext SLIT("Mis-match between the contexts of the signatures for"), nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1), - ppr name <+> dcolon <+> ppr ty]), + ppr id2 <+> dcolon <+> ppr (idType id2)]), ptext SLIT("The signature contexts in a mutually recursive group should all be identical")]