X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=d9b76d2d4f22d17df73452e4531724cd3402384c;hb=49ea1fa53acd2569b0b74c86a981b0d3779515dd;hp=cffcb9cfb939d42e64bb3a40c9b9628b44f703b5;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index cffcb9c..d9b76d2 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -6,8 +6,8 @@ \begin{code} module TcBinds ( tcLocalBinds, tcTopBinds, tcHsBootSigs, tcMonoBinds, - TcPragFun, tcSpecPrag, tcPrags, mkPragFun, - TcSigInfo(..), + TcPragFun, tcSpecPrag, tcPrags, mkPragFun, + TcSigInfo(..), TcSigFun, mkTcSigFun, badBootDeclErr ) where #include "HsVersions.h" @@ -15,7 +15,8 @@ module TcBinds ( tcLocalBinds, tcTopBinds, import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcMonoExpr ) -import DynFlags ( DynFlag(Opt_MonomorphismRestriction, Opt_GlasgowExts) ) +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(..), @@ -170,9 +171,14 @@ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside = do { -- Typecheck the signature ; let { prag_fn = mkPragFun sigs ; ty_sigs = filter isVanillaLSig sigs - ; sig_fn = mkSigFun ty_sigs } + ; sig_fn = mkTcSigFun ty_sigs } ; poly_ids <- mapM tcTySig ty_sigs + -- No recovery from bad signatures, because the type sigs + -- may bind type variables, so proceeding without them + -- can lead to a cascade of errors + -- ToDo: this means we fall over immediately if any type sig + -- is wrong, which is over-conservative, see Trac bug #745 -- Extend the envt right away with all -- the Ids declared with type signatures @@ -358,10 +364,10 @@ tc_poly_binds top_lvl rec_group rec_tc sig_fn prag_fn binds [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked else do -- The normal lifted case: GENERALISE - { is_unres <- isUnRestrictedGroup bind_list sig_fn + { dflags <- getDOpts ; (tyvars_to_gen, dict_binds, dict_ids) <- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $ - generalise top_lvl is_unres mono_bind_infos lie_req + 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 @@ -444,6 +450,8 @@ tcSpecPrag poly_id hs_ty inl ; extendLIEs lie ; let const_dicts = map instToId lie ; return (SpecPrag (mkHsCoerce 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 -------------- -- If typechecking the binds fails, then return with each @@ -555,12 +563,12 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches, bind_fvs = fvs })] sig_fn -- Single function binding non_rec - | Just sig <- sig_fn name -- ...with a type signature + | Just scoped_tvs <- sig_fn name -- ...with a type signature = -- When we have a single function binding, with a type signature -- we can (a) use genuine, rigid skolem constants for the type variables -- (b) bring (rigid) scoped type variables into scope setSrcSpan b_loc $ - do { tc_sig <- tcInstSig True sig + do { tc_sig <- tcInstSig True name scoped_tvs ; mono_name <- newLocalName name ; let mono_ty = sig_tau tc_sig mono_id = mkLocalId mono_name mono_ty @@ -623,7 +631,7 @@ getMonoType (_,_,mono_id) = idType mono_id tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind tcLhs sig_fn (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches }) - = do { mb_sig <- tcInstSig_maybe (sig_fn name) + = do { mb_sig <- tcInstSig_maybe sig_fn name ; mono_name <- newLocalName name ; mono_ty <- mk_mono_ty mb_sig ; let mono_id = mkLocalId mono_name mono_ty @@ -633,7 +641,7 @@ tcLhs sig_fn (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = m mk_mono_ty Nothing = newFlexiTyVarTy argTypeKind tcLhs sig_fn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss }) - = do { mb_sigs <- mapM (tcInstSig_maybe . sig_fn) names + = do { mb_sigs <- mapM (tcInstSig_maybe sig_fn) names ; let nm_sig_prs = names `zip` mb_sigs tau_sig_env = mkNameEnv [ (name, sig_tau sig) | (name, Just sig) <- nm_sig_prs] @@ -692,11 +700,15 @@ getMonoBindInfo tc_binds %************************************************************************ \begin{code} -generalise :: TopLevelFlag -> Bool +generalise :: DynFlags -> TopLevelFlag + -> [LHsBind Name] -> TcSigFun -> [MonoBindInfo] -> [Inst] -> TcM ([TcTyVar], TcDictBinds, [TcId]) -generalise top_lvl is_unrestricted mono_infos lie_req - | not is_unrestricted -- RESTRICTED CASE +generalise dflags top_lvl bind_list sig_fn mono_infos lie_req + | isMonoGroup dflags bind_list + = do { extendLIEs lie_req; return ([], emptyBag, []) } + + | isRestrictedGroup dflags bind_list sig_fn -- RESTRICTED CASE = -- Check signature contexts are empty do { checkTc (all is_mono_sig sigs) (restrictedBindCtxtErr bndrs) @@ -949,15 +961,24 @@ the variable's type, and after that checked to see whether they've been instantiated. \begin{code} -type TcSigFun = Name -> Maybe (LSig Name) +type TcSigFun = Name -> Maybe [Name] -- Maps a let-binder to the list of + -- type variables brought into scope + -- by its type signature. + -- Nothing => no type signature -mkSigFun :: [LSig Name] -> TcSigFun +mkTcSigFun :: [LSig Name] -> TcSigFun -- Search for a particular type signature -- Precondition: the sigs are all type sigs -- Precondition: no duplicates -mkSigFun sigs = lookupNameEnv env +mkTcSigFun sigs = lookupNameEnv env where - env = mkNameEnv [(expectJust "mkSigFun" (sigName sig), sig) | sig <- sigs] + 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 = [] + -- 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.) --------------- data TcSigInfo @@ -1011,14 +1032,16 @@ tcTySig (L span (TypeSig (L _ name) ty)) ; return (mkLocalId name sigma_ty) } ------------------- -tcInstSig_maybe :: Maybe (LSig Name) -> TcM (Maybe TcSigInfo) +tcInstSig_maybe :: TcSigFun -> Name -> TcM (Maybe TcSigInfo) -- Instantiate with *meta* type variables; -- this signature is part of a multi-signature group -tcInstSig_maybe Nothing = return Nothing -tcInstSig_maybe (Just sig) = do { tc_sig <- tcInstSig False sig - ; return (Just tc_sig) } +tcInstSig_maybe sig_fn name + = case sig_fn name of + Nothing -> return Nothing + Just tvs -> do { tc_sig <- tcInstSig False name tvs + ; return (Just tc_sig) } -tcInstSig :: Bool -> LSig Name -> TcM TcSigInfo +tcInstSig :: Bool -> Name -> [Name] -> TcM TcSigInfo -- Instantiate the signature, with either skolems or meta-type variables -- depending on the use_skols boolean -- @@ -1031,9 +1054,8 @@ tcInstSig :: Bool -> LSig Name -> TcM TcSigInfo -- -- We must not use the same 'a' from the defn of T at both places!! -tcInstSig use_skols (L loc (TypeSig (L _ name) hs_ty)) - = setSrcSpan loc $ - do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into +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 @@ -1042,26 +1064,31 @@ tcInstSig use_skols (L loc (TypeSig (L _ name) hs_ty)) ; loc <- getInstLoc (SigOrigin skol_info) ; return (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_theta = theta, sig_tau = tau, - sig_scoped = scoped_names, sig_loc = loc }) } + sig_scoped = final_scoped_names, sig_loc = loc }) } -- Note that the scoped_names and the sig_tvs will have -- different Names. That's quite ok; when we bring the -- scoped_names into scope, we just bind them to the sig_tvs where - -- 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.) -- We also only have scoped type variables when we are instantiating -- with true skolems - scoped_names = case (use_skols, hs_ty) of - (True, L _ (HsForAllTy Explicit tvs _ _)) -> hsLTyVarNames tvs - other -> [] + final_scoped_names | use_skols = scoped_names + | otherwise = [] + +------------------- +isMonoGroup :: DynFlags -> [LHsBind Name] -> Bool +-- No generalisation at all +isMonoGroup dflags binds + = dopt Opt_MonoPatBinds dflags && any is_pat_bind binds + where + is_pat_bind (L _ (PatBind {})) = True + is_pat_bind other = False ------------------- -isUnRestrictedGroup :: [LHsBind Name] -> TcSigFun -> TcM Bool -isUnRestrictedGroup binds sig_fn - = do { mono_restriction <- doptM Opt_MonomorphismRestriction - ; return (not mono_restriction || all_unrestricted) } +isRestrictedGroup :: DynFlags -> [LHsBind Name] -> TcSigFun -> Bool +isRestrictedGroup dflags binds sig_fn + = mono_restriction && not all_unrestricted where + mono_restriction = dopt Opt_MonomorphismRestriction dflags all_unrestricted = all (unrestricted . unLoc) binds has_sig n = isJust (sig_fn n)