X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=e5a83ab3cbf488d0d99caad471a7b6b12f17b943;hb=e0d750bedbd33f7a133c8c82c35fd8db537ab649;hp=a50bc502d023779bd6740f94fc1239d8f293ac3d;hpb=39068cf49bf3553f90ec316569619c310a6be8de;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index a50bc50..e5a83ab 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -27,35 +27,32 @@ import Inst ( LIE, emptyLIE, mkLIE, plusLIE, InstOrigin(..), import TcEnv ( tcExtendLocalValEnv, newSpecPragmaId, newLocalId ) -import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck, tcSimplifyRestricted, tcSimplifyToDicts ) -import TcMonoType ( tcHsSigType, checkSigTyVars, +import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts ) +import TcMonoType ( tcHsSigType, UserTypeCtxt(..), checkSigTyVars, TcSigInfo(..), tcTySig, maybeSig, sigCtxt ) import TcPat ( tcPat ) import TcSimplify ( bindInstsOfLocalFuns ) -import TcType ( newTyVarTy, newTyVar, - zonkTcTyVarToTyVar +import TcMType ( newTyVarTy, newTyVar, + zonkTcTyVarToTyVar, + unifyTauTy, unifyTauTyLists + ) +import TcType ( mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType, + mkPredTy, mkForAllTy, isUnLiftedType, + unliftedTypeKind, liftedTypeKind, openTypeKind, eqKind ) -import TcUnify ( unifyTauTy, unifyTauTyLists ) import CoreFVs ( idFreeTyVars ) import Id ( mkLocalId, setInlinePragma ) import Var ( idType, idName ) -import IdInfo ( InlinePragInfo(..) ) import Name ( Name, getOccName, getSrcLoc ) import NameSet -import Type ( mkTyVarTy, tyVarsOfTypes, - mkForAllTys, mkFunTys, tyVarsOfType, - mkPredTy, mkForAllTy, isUnLiftedType, - unliftedTypeKind, liftedTypeKind, openTypeKind - ) import Var ( tyVarKind ) import VarSet import Bag import Util ( isIn ) -import ListSetOps ( minusList ) -import Maybes ( maybeToBool ) -import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isNotTopLevel ) +import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isNotTopLevel, + isAlwaysActive ) import FiniteMap ( listToFM, lookupFM ) import Outputable \end{code} @@ -225,10 +222,12 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec -- TYPECHECK THE BINDINGS tcMonoBinds mbind tc_ty_sigs is_rec `thenTc` \ (mbind', lie_req, binder_names, mono_ids) -> let - tau_tvs = varSetElems (foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids) + tau_tvs = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids in -- GENERALISE + tcAddSrcLoc (minimum (map getSrcLoc binder_names)) $ + tcAddErrCtxt (genCtxt binder_names) $ generalise binder_names mbind tau_tvs lie_req tc_ty_sigs `thenTc` \ (tc_tyvars_to_gen, lie_free, dict_binds, dict_ids) -> @@ -258,14 +257,10 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec exports = zipWith mk_export binder_names zonked_mono_ids dict_tys = map idType zonked_dict_ids - inlines = mkNameSet [name | InlineSig name _ loc <- inline_sigs] - no_inlines = listToFM ([(name, IMustNotBeINLINEd False phase) | NoInlineSig name phase loc <- inline_sigs] ++ - [(name, IMustNotBeINLINEd True phase) | InlineSig name phase loc <- inline_sigs, maybeToBool phase]) - -- "INLINE n foo" means inline foo, but not until at least phase n - -- "NOINLINE n foo" means don't inline foo until at least phase n, and even - -- then only if it is small enough etc. - -- "NOINLINE foo" means don't inline foo ever, which we signal with a (IMustNotBeINLINEd Nothing) - -- See comments in CoreUnfold.blackListed for the Authorised Version + inlines = mkNameSet [name | InlineSig True name _ loc <- inline_sigs] + no_inlines = listToFM [(name, phase) | InlineSig _ name phase _ <- inline_sigs, + not (isAlwaysActive phase)] + -- AlwaysActive is the default, so don't bother with them mk_export binder_name zonked_mono_id = (tyvars, @@ -309,7 +304,7 @@ attachNoInlinePrag no_inlines bndr Nothing -> bndr checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind zonked_mono_ids - = ASSERT( not (any ((== unliftedTypeKind) . tyVarKind) real_tyvars_to_gen) ) + = ASSERT( not (any ((eqKind unliftedTypeKind) . tyVarKind) real_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 @@ -411,20 +406,29 @@ is doing. %************************************************************************ \begin{code} -generalise_help doc tau_tvs lie_req sigs +generalise binder_names mbind tau_tvs lie_req sigs + | not is_unrestricted -- RESTRICTED CASE + = -- Check signature contexts are empty + checkTc (all is_mono_sig sigs) + (restrictedBindCtxtErr binder_names) `thenTc_` ------------------------ - | null sigs - = -- INFERENCE CASE: Unrestricted group, no type signatures - tcSimplifyInfer doc - tau_tvs lie_req + -- Now simplify with exactly that set of tyvars + -- We have to squash those Methods + tcSimplifyRestricted doc tau_tvs lie_req `thenTc` \ (qtvs, lie_free, binds) -> ------------------------ - | otherwise + -- Check that signature type variables are OK + checkSigsTyVars sigs `thenTc_` + + returnTc (qtvs, lie_free, binds, []) + + | null sigs -- UNRESTRICTED CASE, NO TYPE SIGS + = tcSimplifyInfer doc tau_tvs lie_req + + | otherwise -- UNRESTRICTED CASE, WITH TYPE SIGS = -- CHECKING CASE: Unrestricted group, there are type signatures -- Check signature contexts are empty checkSigsCtxts sigs `thenTc` \ (sig_avails, sig_dicts) -> - + -- Check that the needed dicts can be -- expressed in terms of the signature ones tcSimplifyInferCheck doc tau_tvs sig_avails lie_req `thenTc` \ (forall_tvs, lie_free, dict_binds) -> @@ -434,44 +438,12 @@ generalise_help doc tau_tvs lie_req sigs returnTc (forall_tvs, lie_free, dict_binds, sig_dicts) -generalise binder_names mbind tau_tvs lie_req sigs - | is_unrestricted -- UNRESTRICTED CASE - = generalise_help doc tau_tvs lie_req sigs - - | otherwise -- RESTRICTED CASE - = -- Do a simplification to decide what type variables - -- are constrained. We can't just take the free vars - -- of lie_req because that'll have methods that may - -- incidentally mention entirely unconstrained variables - -- e.g. a call to f :: Eq a => a -> b -> b - -- Here, b is unconstrained. A good example would be - -- foo = f (3::Int) - -- We want to infer the polymorphic type - -- foo :: forall b. b -> b - generalise_help doc tau_tvs lie_req sigs `thenTc` \ (forall_tvs, lie_free, dict_binds, dict_ids) -> - - -- Check signature contexts are empty - checkTc (null sigs || null dict_ids) - (restrictedBindCtxtErr binder_names) `thenTc_` - - -- Identify constrained tyvars - let - constrained_tvs = varSetElems (tyVarsOfTypes (map idType dict_ids)) - -- The dict_ids are fully zonked - final_forall_tvs = forall_tvs `minusList` constrained_tvs - in - - -- Now simplify with exactly that set of tyvars - -- We have to squash those Methods - tcSimplifyRestricted doc final_forall_tvs [] lie_req `thenTc` \ (lie_free, binds) -> - - returnTc (final_forall_tvs, lie_free, binds, []) - where is_unrestricted | opt_NoMonomorphismRestriction = True | otherwise = isUnRestrictedGroup tysig_names mbind tysig_names = [name | (TySigInfo name _ _ _ _ _ _ _) <- sigs] + is_mono_sig (TySigInfo _ _ _ theta _ _ _ _) = null theta doc = ptext SLIT("type signature(s) for") <+> pprBinders binder_names @@ -483,8 +455,9 @@ generalise binder_names mbind tau_tvs lie_req sigs -- We unify them because, with polymorphic recursion, their types -- might not otherwise be related. This is a rather subtle issue. -- ToDo: amplify -checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ _ : other_sigs) - = mapTc_ check_one other_sigs `thenTc_` +checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ src_loc : other_sigs) + = tcAddSrcLoc src_loc $ + mapTc_ check_one other_sigs `thenTc_` if null theta1 then returnTc ([], []) -- Non-overloaded type signatures else @@ -502,8 +475,7 @@ checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ _ : other_sigs) sig_meths = concat [insts | TySigInfo _ _ _ _ _ _ insts _ <- sigs] check_one sig@(TySigInfo _ id _ theta _ _ _ src_loc) - = tcAddSrcLoc src_loc $ - tcAddErrCtxt (sigContextsCtxt id1 id) $ + = tcAddErrCtxt (sigContextsCtxt id1 id) $ checkTc (length theta == n_sig1_theta) sigContextsErr `thenTc_` unifyTauTyLists sig1_dict_tys (map mkPredTy theta) @@ -683,8 +655,9 @@ tcMonoBinds mbinds tc_ty_sigs is_rec newTyVarTy kind `thenNF_Tc` \ pat_ty -> -- Now typecheck the pattern - -- We don't support binding fresh type variables in the - -- pattern of a pattern binding. For example, this is illegal: + -- We don't support binding fresh (not-already-in-scope) scoped + -- type variables in the pattern of a pattern binding. + -- For example, this is illegal: -- (x::a, y::b) = e -- whereas this is ok -- (x::Int, y::Bool) = e @@ -697,7 +670,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec complete_it xve = tcAddSrcLoc locn $ tcAddErrCtxt (patMonoBindsCtxt bind) $ tcExtendLocalValEnv xve $ - tcGRHSs grhss pat_ty PatBindRhs `thenTc` \ (grhss', lie) -> + tcGRHSs PatBindRhs grhss pat_ty `thenTc` \ (grhss', lie) -> returnTc (PatMonoBind pat' grhss' locn, lie) in returnTc (complete_it, lie_req, tvs, ids, lie_avail) @@ -759,7 +732,7 @@ tcSpecSigs (SpecSig name poly_ty src_loc : sigs) tcAddErrCtxt (valSpecSigCtxt name poly_ty) $ -- Get and instantiate its alleged specialised type - tcHsSigType poly_ty `thenTc` \ sig_ty -> + tcHsSigType (FunSigCtxt name) poly_ty `thenTc` \ sig_ty -> -- Check that f has a more general type, and build a RHS for -- the spec-pragma-id at the same time @@ -803,9 +776,10 @@ valSpecSigCtxt v ty sigContextsErr = ptext SLIT("Mismatched contexts") sigContextsCtxt s1 s2 - = hang (hsep [ptext SLIT("When matching the contexts of the signatures for"), - quotes (ppr s1), ptext SLIT("and"), quotes (ppr s2)]) - 4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)")) + = vcat [ptext SLIT("When matching the contexts of the signatures for"), + nest 2 (vcat [ppr s1 <+> dcolon <+> ppr (idType s1), + ppr s2 <+> dcolon <+> ppr (idType s2)]), + ptext SLIT("The signature contexts in a mutually recursive group should all be identical")] ----------------------------------------------- unliftedBindErr flavour mbind @@ -825,6 +799,9 @@ restrictedBindCtxtErr binder_names 4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names, ptext SLIT("that falls under the monomorphism restriction")]) +genCtxt binder_names + = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names + -- Used in error messages pprBinders bndrs = pprWithCommas ppr bndrs \end{code}