X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=7978dad9246042a9733cd8f0351f4f71046932c3;hp=a5b15f3cdd0a6e6c8d2b9ea709adfd52e43a295a;hb=c279f61e3762b137c035ca0bae960415a8916f03;hpb=d95ce839533391e7118257537044f01cbb1d6694 diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index a5b15f3..7978dad 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -7,7 +7,7 @@ \begin{code} module TcBinds ( tcLocalBinds, tcTopBinds, tcHsBootSigs, tcMonoBinds, tcPolyBinds, - TcPragFun, tcSpecPrag, tcPrags, mkPragFun, + TcPragFun, tcPrags, mkPragFun, TcSigInfo(..), TcSigFun, mkTcSigFun, badBootDeclErr ) where @@ -26,7 +26,6 @@ import TcHsType import TcPat import TcMType import TcType -import {- Kind parts of -} Type import Coercion import VarEnv import TysPrim @@ -41,12 +40,12 @@ import Bag import ErrUtils import Digraph import Maybes -import List import Util import BasicTypes import Outputable import FastString +import Data.List( partition ) import Control.Monad \end{code} @@ -98,7 +97,7 @@ tcHsBootSigs :: HsValBinds Name -> TcM [Id] -- signatures in it. The renamer checked all this tcHsBootSigs (ValBindsOut binds sigs) = do { checkTc (null binds) badBootDeclErr - ; mapM (addLocM tc_boot_sig) (filter isVanillaLSig sigs) } + ; mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } where tc_boot_sig (TypeSig (L _ name) ty) = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty @@ -150,8 +149,8 @@ tcValBinds _ (ValBindsIn binds _) _ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside = do { -- Typecheck the signature - ; let { prag_fn = mkPragFun sigs - ; ty_sigs = filter isVanillaLSig sigs + ; let { prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds) + ; ty_sigs = filter isTypeLSig sigs ; sig_fn = mkTcSigFun ty_sigs } ; poly_ids <- checkNoErrs (mapAndRecoverM tcTySig ty_sigs) @@ -311,7 +310,7 @@ tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragFun tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds = let bind_list = bagToList binds - binder_names = collectHsBindBinders binds + binder_names = collectHsBindsBinders binds loc = getLoc (head bind_list) -- TODO: location a bit awkward, but the mbinds have been -- dependency analysed and may no longer be adjacent @@ -337,9 +336,13 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds ; if is_strict then do { 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 (_, Just sig, mono_id) _ = ([], sig_id sig, mono_id, []) - -- ToDo: prags for unlifted bindings + mk_export (name, mb_sig, mono_id) mono_ty + = ([], the_id, mono_id, noSpecPrags) + -- ToDo: prags for unlifted bindings + where + the_id = case mb_sig of + Just sig -> sig_id sig + Nothing -> mkLocalId name mono_ty ; return ( unitBag $ L loc $ AbsBinds [] [] exports binds', [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked @@ -352,7 +355,8 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds -- BUILD THE POLYMORPHIC RESULT IDs ; let dict_vars = map instToVar dicts -- May include equality constraints - ; exports <- mapM (mkExport top_lvl rec_group prag_fn tyvars_to_gen (map varType dict_vars)) + ; exports <- mapM (mkExport top_lvl rec_group (length mono_bind_infos > 1) + prag_fn tyvars_to_gen (map varType dict_vars)) mono_bind_infos ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports] @@ -367,9 +371,12 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds -------------- -mkExport :: TopLevelFlag -> RecFlag -> TcPragFun -> [TyVar] -> [TcType] +mkExport :: TopLevelFlag -> RecFlag + -> Bool -- More than one variable is bound, so we'll desugar to + -- a tuple, so INLINE pragmas won't work + -> TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo - -> TcM ([TyVar], Id, Id, [LPrag]) + -> TcM ([TyVar], Id, Id, TcSpecPrags) -- mkExport generates exports with -- zonked type variables, -- zonked poly_ids @@ -381,16 +388,18 @@ mkExport :: TopLevelFlag -> RecFlag -> TcPragFun -> [TyVar] -> [TcType] -- Pre-condition: the inferred_tvs are already zonked -mkExport top_lvl rec_group prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id) +mkExport top_lvl rec_group multi_bind 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 has a zonked type - ; prags <- tcPrags rec_group poly_id (prag_fn poly_name) + ; (poly_id', spec_prags) <- tcPrags rec_group multi_bind (notNull dict_tys) + poly_id (prag_fn poly_name) -- tcPrags requires a zonked poly_id - ; return (tvs, poly_id, mono_id, prags) } + ; return (tvs, poly_id', mono_id, SpecPrags spec_prags) } where poly_ty = mkForAllTys inferred_tvs (mkFunTys dict_tys (idType mono_id)) @@ -405,52 +414,116 @@ mkExport top_lvl rec_group prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mon ------------------------ type TcPragFun = Name -> [LSig Name] -mkPragFun :: [LSig Name] -> TcPragFun -mkPragFun sigs = \n -> lookupNameEnv env n `orElse` [] - where - prs = [(expectJust "mkPragFun" (sigName sig), sig) - | sig <- sigs, isPragLSig sig] - env = foldl add emptyNameEnv prs - add env (n,p) = extendNameEnv_Acc (:) singleton env n p - -tcPrags :: RecFlag -> Id -> [LSig Name] -> TcM [LPrag] +mkPragFun :: [LSig Name] -> LHsBinds Name -> TcPragFun +mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` [] + where + prs = mapCatMaybes get_sig sigs + + get_sig :: LSig Name -> Maybe (Located Name, LSig Name) + get_sig (L l (SpecSig nm ty inl)) = Just (nm, L l $ SpecSig nm ty (add_arity nm inl)) + get_sig (L l (InlineSig nm inl)) = Just (nm, L l $ InlineSig nm (add_arity nm inl)) + get_sig _ = Nothing + + add_arity (L _ n) inl_prag -- Adjust inl_sat field to match visible arity of function + | Just ar <- lookupNameEnv ar_env n = inl_prag { inl_sat = Just ar } + | otherwise = inl_prag + + prag_env :: NameEnv [LSig Name] + prag_env = foldl add emptyNameEnv prs + add env (L _ n,p) = extendNameEnv_Acc (:) singleton env n p + + -- ar_env maps a local to the arity of its definition + ar_env :: NameEnv Arity + ar_env = foldrBag lhsBindArity emptyNameEnv binds + +lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity +lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env + = extendNameEnv env (unLoc id) (matchGroupArity ms) +lhsBindArity _ env = env -- PatBind/VarBind + +tcPrags :: RecFlag + -> Bool -- True <=> AbsBinds binds more than one variable + -> Bool -- True <=> function is overloaded + -> Id -> [LSig Name] + -> TcM (Id, [Located TcSpecPrag]) +-- Add INLINE and SPECLIASE pragmas +-- INLINE prags are added to the (polymorphic) Id directly +-- SPECIALISE prags are passed to the desugarer via TcSpecPrags -- Pre-condition: the poly_id is zonked -- Reason: required by tcSubExp -tcPrags rec_group poly_id prags = mapM tc_lprag prags +tcPrags _rec_group _multi_bind is_overloaded_id poly_id prag_sigs + = do { poly_id' <- tc_inl inl_sigs + + ; spec_prags <- mapM (wrapLocM (tcSpecPrag poly_id')) spec_sigs + + ; unless (null spec_sigs || is_overloaded_id) warn_discarded_spec + + ; unless (null bad_sigs) warn_discarded_sigs + + ; return (poly_id', spec_prags) } where - tc_lprag :: LSig Name -> TcM LPrag - tc_lprag (L loc prag) = setSrcSpan loc $ - addErrCtxt (pragSigCtxt prag) $ - do { prag' <- tc_prag prag - ; return (L loc prag') } - - tc_prag (SpecSig _ hs_ty inl) = tcSpecPrag poly_id hs_ty inl - tc_prag (SpecInstSig hs_ty) = tcSpecPrag poly_id hs_ty defaultInlineSpec - tc_prag (InlineSig _ inl) = do { warnIfRecInline rec_group inl poly_id - ; return (InlinePrag inl) } - tc_prag (FixSig {}) = panic "tcPrag FixSig" - tc_prag (TypeSig {}) = panic "tcPrag TypeSig" - -pragSigCtxt :: Sig Name -> SDoc -pragSigCtxt prag = hang (ptext (sLit "In the pragma")) 2 (ppr prag) - -warnIfRecInline :: RecFlag -> InlineSpec -> TcId -> TcM () -warnIfRecInline rec_group (Inline _ is_inline) poly_id - | is_inline && isRec rec_group = addWarnTc warn - | otherwise = return () + (inl_sigs, other_sigs) = partition isInlineLSig prag_sigs + (spec_sigs, bad_sigs) = partition isSpecLSig other_sigs + + warn_discarded_spec = warnPrags poly_id spec_sigs $ + ptext (sLit "SPECIALISE pragmas for non-overloaded function") + warn_dup_inline = warnPrags poly_id inl_sigs $ + ptext (sLit "Duplicate INLINE pragmas for") + warn_discarded_sigs = warnPrags poly_id bad_sigs $ + ptext (sLit "Discarding unexpected pragmas for") + + ----------- + tc_inl [] = return poly_id + tc_inl (L loc (InlineSig _ prag) : other_inls) + = do { unless (null other_inls) (setSrcSpan loc warn_dup_inline) + ; return (poly_id `setInlinePragma` prag) } + tc_inl _ = panic "tc_inl" + +{- Earlier we tried to warn about + (a) INLINE for recursive function + (b) INLINE for function that is part of a multi-binder group + Code fragments below. But we want to allow + {-# INLINE f #-} + f x = x : g y + g y = ....f...f.... + even though they are mutually recursive. + So I'm just omitting the warnings for now + + | multi_bind && isInlinePragma prag + = do { setSrcSpan loc $ addWarnTc multi_bind_warn + ; return poly_id } + | otherwise + ; when (isInlinePragma prag && isRec rec_group) + (setSrcSpan loc (addWarnTc rec_inline_warn)) + + rec_inline_warn = ptext (sLit "INLINE pragma for recursive binder") + <+> quotes (ppr poly_id) <+> ptext (sLit "may be discarded") + + multi_bind_warn = hang (ptext (sLit "Discarding INLINE pragma for") <+> quotes (ppr poly_id)) + 2 (ptext (sLit "because it is bound by a pattern, or mutual recursion") ) +-} + + +warnPrags :: Id -> [LSig Name] -> SDoc -> TcM () +warnPrags id bad_sigs herald + = addWarnTc (hang (herald <+> quotes (ppr id)) + 2 (ppr_sigs bad_sigs)) where - warn = ptext (sLit "INLINE pragma for recursive binder") <+> quotes (ppr poly_id) - <+> ptext (sLit "may be discarded") + ppr_sigs sigs = vcat (map (ppr . getLoc) sigs) -tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag -tcSpecPrag poly_id hs_ty inl - = do { let name = idName poly_id +-------------- +tcSpecPrag :: TcId -> Sig Name -> TcM TcSpecPrag +tcSpecPrag poly_id prag@(SpecSig _ hs_ty inl) + = addErrCtxt (spec_ctxt prag) $ + do { let name = idName poly_id ; spec_ty <- tcHsSigType (FunSigCtxt name) hs_ty ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty - ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty inl) } - -- Most of the work of specialisation is done by - -- the desugarer, guided by the SpecPrag - + ; return (SpecPrag co_fn inl) } + where + spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) +tcSpecPrag _ sig = pprPanic "tcSpecPrag" (ppr sig) + + -------------- -- If typechecking the binds fails, then return with each -- signature-less binder given type (forall a.a), to minimise @@ -486,6 +559,12 @@ checkStrictBinds top_lvl rec_group mbind mono_tys infos (strictBindErr "Recursive" unlifted mbind) ; checkTc (isSingletonBag mbind) (strictBindErr "Multiple" unlifted mbind) + -- This should be a checkTc, not a warnTc, but as of GHC 6.11 + -- the versions of alex and happy available have non-conforming + -- templates, so the GHC build fails if it's an error: + ; warnUnlifted <- doptM Opt_WarnLazyUnliftedBindings + ; warnTc (warnUnlifted && not bang_pat) + (unliftedMustBeBang mbind) ; mapM_ check_sig infos ; return True } | otherwise @@ -497,6 +576,12 @@ checkStrictBinds top_lvl rec_group mbind mono_tys infos (badStrictSig unlifted sig) check_sig _ = return () +unliftedMustBeBang :: LHsBindsLR Var Var -> SDoc +unliftedMustBeBang mbind + = hang (text "Bindings containing unlifted types must use an outermost bang pattern:") + 4 (pprLHsBinds mbind) + $$ text "*** This will be an error in GHC 6.14! Fix your code now!" + strictBindErr :: String -> Bool -> LHsBindsLR Var Var -> SDoc strictBindErr flavour unlifted mbind = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:")) @@ -735,7 +820,7 @@ generalise :: DynFlags -> TopLevelFlag -- The returned [TyVar] are all ready to quantify generalise dflags top_lvl bind_list sig_fn mono_infos lie_req - | isMonoGroup dflags bind_list + | isMonoGroup dflags top_lvl bind_list sigs = do { extendLIEs lie_req ; return ([], [], emptyBag) } @@ -806,7 +891,8 @@ unifyCtxts :: [TcSigInfo] -> TcM [Inst] -- Post-condition: the returned Insts are full zonked unifyCtxts [] = panic "unifyCtxts []" unifyCtxts (sig1 : sigs) -- Argument is always non-empty - = do { mapM unify_ctxt sigs + = do { traceTc $ text "unifyCtxts" <+> ppr (sig1 : sigs) + ; mapM_ unify_ctxt sigs ; theta <- zonkTcThetaType (sig_theta sig1) ; newDictBndrs (sig_loc sig1) theta } where @@ -823,7 +909,7 @@ unifyCtxts (sig1 : sigs) -- Argument is always non-empty -- where F is a type function and (F a ~ [a]) -- Then unification might succeed with a coercion. But it's much -- much simpler to require that such signatures have identical contexts - checkTc (all isIdentityCoercion cois) + checkTc (all isIdentityCoI cois) (ptext (sLit "Mutually dependent functions have syntactically distinct contexts")) } @@ -865,7 +951,7 @@ checkDistinctTyVars :: [TcTyVar] -> TcM [TcTyVar] checkDistinctTyVars sig_tvs = do { zonked_tvs <- mapM zonkSigTyVar sig_tvs - ; foldlM check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs) + ; foldlM_ check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs) ; return zonked_tvs } where check_dup :: TyVarEnv TcTyVar -> (TcTyVar, TcTyVar) -> TcM (TyVarEnv TcTyVar) @@ -1055,8 +1141,10 @@ mkTcSigFun :: [LSig Name] -> TcSigFun -- Precondition: no duplicates mkTcSigFun sigs = lookupNameEnv env where - env = mkNameEnv [(name, hsExplicitTvs lhs_ty) - | L _ (TypeSig (L _ name) lhs_ty) <- sigs] + env = mkNameEnv (mapCatMaybes mk_pair sigs) + mk_pair (L _ (TypeSig (L _ name) lhs_ty)) = Just (name, hsExplicitTvs lhs_ty) + mk_pair (L _ (IdSig id)) = Just (idName id, []) + mk_pair _ = Nothing -- 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 [More instantiated than scoped].) @@ -1110,6 +1198,8 @@ tcTySig (L span (TypeSig (L _ name) ty)) = setSrcSpan span $ do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty ; return (mkLocalId name sigma_ty) } +tcTySig (L _ (IdSig id)) + = return id tcTySig s = pprPanic "tcTySig" (ppr s) ------------------- @@ -1154,10 +1244,12 @@ tcInstSig use_skols name sig_loc = loc }) } ------------------- -isMonoGroup :: DynFlags -> [LHsBind Name] -> Bool +isMonoGroup :: DynFlags -> TopLevelFlag -> [LHsBind Name] + -> [TcSigInfo] -> Bool -- No generalisation at all -isMonoGroup dflags binds - = dopt Opt_MonoPatBinds dflags && any is_pat_bind binds +isMonoGroup dflags top_lvl binds sigs + = (dopt Opt_MonoPatBinds dflags && any is_pat_bind binds) + || (dopt Opt_MonoLocalBinds dflags && null sigs && not (isTopLevel top_lvl)) where is_pat_bind (L _ (PatBind {})) = True is_pat_bind _ = False