X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=2871f3bd58b027dc1851cfeba29f2ec69c37fba9;hb=e9f9ec1e57d53b9302a395ce0d02c0fa59e28341;hp=45e3264e09dc225a523757443c4d7891dd4daae9;hpb=1b68b94fcde73a92a371730b210b5b1c8678a44f;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 45e3264..2871f3b 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -5,16 +5,9 @@ \section[TcBinds]{TcBinds} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module TcBinds ( tcLocalBinds, tcTopBinds, - tcHsBootSigs, tcMonoBinds, - TcPragFun, tcSpecPrag, tcPrags, mkPragFun, + tcHsBootSigs, tcMonoBinds, tcPolyBinds, + TcPragFun, tcPrags, mkPragFun, TcSigInfo(..), TcSigFun, mkTcSigFun, badBootDeclErr ) where @@ -23,7 +16,6 @@ import {-# SOURCE #-} TcExpr ( tcMonoExpr ) import DynFlags import HsSyn -import TcHsSyn import TcRnMonad import Inst @@ -34,13 +26,11 @@ import TcHsType import TcPat import TcMType import TcType -import {- Kind parts of -} Type import Coercion import VarEnv import TysPrim import Id -import IdInfo -import Var ( TyVar, varType ) +import Var import Name import NameSet import NameEnv @@ -50,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} @@ -107,12 +97,13 @@ 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 - ; return (mkVanillaGlobal name sigma_ty vanillaIdInfo) } + ; return (mkVanillaGlobal name sigma_ty) } -- Notice that we make GlobalIds, not LocalIds + tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups) badBootDeclErr :: Message @@ -153,16 +144,16 @@ tcValBinds :: TopLevelFlag -> HsValBinds Name -> TcM thing -> TcM (HsValBinds TcId, thing) -tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside +tcValBinds _ (ValBindsIn binds _) _ = pprPanic "tcValBinds" (ppr 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 <- mapM tcTySig ty_sigs + ; poly_ids <- checkNoErrs (mapAndRecoverM 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 @@ -173,26 +164,29 @@ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside -- the Ids declared with type signatures ; poly_rec <- doptM Opt_RelaxedPolyRec ; (binds', thing) <- tcExtendIdEnv poly_ids $ - tc_val_binds poly_rec top_lvl sig_fn prag_fn + tcBindGroups poly_rec top_lvl sig_fn prag_fn binds thing_inside ; return (ValBindsOut binds' sigs, thing) } ------------------------ -tc_val_binds :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun +tcBindGroups :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun -> [(RecFlag, LHsBinds Name)] -> TcM thing -> TcM ([(RecFlag, LHsBinds TcId)], thing) -- Typecheck a whole lot of value bindings, -- one strongly-connected component at a time +-- Here a "strongly connected component" has the strightforward +-- meaning of a group of bindings that mention each other, +-- ignoring type signatures (that part comes later) -tc_val_binds poly_rec top_lvl sig_fn prag_fn [] thing_inside +tcBindGroups _ _ _ _ [] thing_inside = do { thing <- thing_inside ; return ([], thing) } -tc_val_binds poly_rec top_lvl sig_fn prag_fn (group : groups) thing_inside +tcBindGroups poly_rec top_lvl sig_fn prag_fn (group : groups) thing_inside = do { (group', (groups', thing)) <- 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 + tcBindGroups poly_rec top_lvl sig_fn prag_fn groups thing_inside ; return (group' ++ groups', thing) } ------------------------ @@ -204,52 +198,61 @@ tc_group :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun -- We get a list of groups back, because there may -- be specialisations etc as well -tc_group poly_rec top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside +tc_group _ 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) } + = do { (binds1, lie_binds, thing) <- tc_haskell98 top_lvl sig_fn prag_fn + NonRecursive binds thing_inside + ; return ( [(NonRecursive, unitBag b) | b <- bagToList binds1] + ++ [(Recursive, lie_binds)] -- TcDictBinds have scrambled dependency order + , thing) } 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) } + = do { (binds1, lie_binds, thing) <- tc_haskell98 top_lvl sig_fn prag_fn + Recursive binds thing_inside + ; return ([(Recursive, binds1 `unionBags` lie_binds)], thing) } - | otherwise -- Recursive group, with gla-exts - = -- To maximise polymorphism (with -fglasgow-exts), we do a new + | otherwise -- Recursive group, with -XRelaxedPolyRec + = -- To maximise polymorphism (with -XRelaxedPolyRec), we do a new -- strongly-connected-component analysis, this time omitting -- any references to variables with type signatures. -- - -- Notice that the bindInsts thing covers *all* the bindings in the original - -- group at once; an earlier one may use a later one! + -- Notice that the bindInsts thing covers *all* the bindings in + -- the original group at once; an earlier one may use a later one! do { traceTc (text "tc_group rec" <+> pprLHsBinds binds) - ; (binds1,thing) <- bindLocalInsts top_lvl $ - go (stronglyConnComp (mkEdges sig_fn binds)) - ; return ([(Recursive, unionManyBags binds1)], thing) } + ; (binds1,lie_binds,thing) <- bindLocalInsts top_lvl $ + go (stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)) + ; return ([(Recursive, binds1 `unionBags` lie_binds)], thing) } -- Rec them all together where --- go :: SCC (LHsBind Name) -> TcM ([LHsBind TcId], [TcId], thing) +-- go :: SCC (LHsBind Name) -> TcM (LHsBinds TcId, [TcId], thing) go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc ; (binds2, ids2, thing) <- tcExtendIdEnv ids1 $ go sccs - ; return (binds1 ++ binds2, ids1 ++ ids2, thing) } - go [] = do { thing <- thing_inside; return ([], [], thing) } + ; return (binds1 `unionBags` binds2, ids1 ++ ids2, thing) } + go [] = do { thing <- thing_inside; return (emptyBag, [], thing) } tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive (unitBag bind) tc_scc (CyclicSCC binds) = tc_sub_group Recursive (listToBag binds) tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive +tc_haskell98 :: TopLevelFlag -> TcSigFun -> TcPragFun -> RecFlag + -> LHsBinds Name -> TcM a -> TcM (LHsBinds TcId, TcDictBinds, a) tc_haskell98 top_lvl sig_fn prag_fn rec_flag binds thing_inside - = bindLocalInsts top_lvl $ do - { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn rec_flag rec_flag binds - ; thing <- tcExtendIdEnv ids thing_inside - ; return (binds1, ids, thing) } + = bindLocalInsts top_lvl $ + do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn rec_flag rec_flag binds + ; thing <- tcExtendIdEnv ids thing_inside + ; return (binds1, ids, thing) } ------------------------ -bindLocalInsts :: TopLevelFlag -> TcM ([LHsBinds TcId], [TcId], a) -> TcM ([LHsBinds TcId], a) +bindLocalInsts :: TopLevelFlag + -> TcM (LHsBinds TcId, [TcId], a) + -> TcM (LHsBinds TcId, TcDictBinds, a) bindLocalInsts top_lvl thing_inside - | isTopLevel top_lvl = do { (binds, ids, thing) <- thing_inside; return (binds, thing) } + | isTopLevel top_lvl + = do { (binds, _, thing) <- thing_inside; return (binds, emptyBag, thing) } -- For the top level don't bother with all this bindInstsOfLocalFuns stuff. -- All the top level things are rec'd together anyway, so it's fine to -- leave them to the tcSimplifyTop, and quite a bit faster too @@ -257,7 +260,7 @@ bindLocalInsts top_lvl thing_inside | otherwise -- Nested case = do { ((binds, ids, thing), lie) <- getLIE thing_inside ; lie_binds <- bindInstsOfLocalFuns lie ids - ; return (binds ++ [lie_binds], thing) } + ; return (binds, lie_binds, thing) } ------------------------ mkEdges :: TcSigFun -> LHsBinds Name @@ -283,6 +286,8 @@ mkEdges sig_fn binds bindersOfHsBind :: HsBind Name -> [Name] bindersOfHsBind (PatBind { pat_lhs = pat }) = collectPatBinders pat bindersOfHsBind (FunBind { fun_id = L _ f }) = [f] +bindersOfHsBind (AbsBinds {}) = panic "bindersOfHsBind AbsBinds" +bindersOfHsBind (VarBind {}) = panic "bindersOfHsBind VarBind" ------------------------ tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragFun @@ -290,7 +295,7 @@ tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragFun -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures -> LHsBinds Name - -> TcM ([LHsBinds TcId], [TcId]) + -> TcM (LHsBinds TcId, [TcId]) -- Typechecks a single bunch of bindings all together, -- and generalises them. The bunch may be only part of a recursive @@ -331,11 +336,15 @@ 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 (name, Just sig, mono_id) mono_ty = ([], sig_id sig, mono_id, []) - -- ToDo: prags for unlifted bindings - - ; return ( [unitBag $ L loc $ AbsBinds [] [] exports binds'], + 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 else do -- The normal lifted case: GENERALISE @@ -346,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 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] @@ -356,14 +366,17 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds dict_vars exports (dict_binds `unionBags` binds') - ; return ([unitBag abs_bind], poly_ids) -- poly_ids are guaranteed zonked by mkExport + ; return (unitBag abs_bind, poly_ids) -- poly_ids are guaranteed zonked by mkExport } } -------------- -mkExport :: TopLevelFlag -> 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 @@ -375,23 +388,25 @@ mkExport :: TopLevelFlag -> TcPragFun -> [TyVar] -> [TcType] -- Pre-condition: the inferred_tvs are already zonked -mkExport top_lvl 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 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)) mk_poly_id warn Nothing = do { poly_ty' <- zonkTcType poly_ty ; 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) + mk_poly_id _ (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) } @@ -399,47 +414,128 @@ mkExport top_lvl prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id) ------------------------ 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 :: Id -> [LSig Name] -> TcM [LPrag] -tcPrags poly_id prags = mapM (wrapLocM tc_prag) prags +mkPragFun :: [LSig Name] -> LHsBinds Name -> TcPragFun +mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` [] where - tc_prag prag = addErrCtxt (pragSigCtxt prag) $ - tcPrag poly_id prag - -pragSigCtxt prag = hang (ptext (sLit "In the pragma")) 2 (ppr prag) - -tcPrag :: TcId -> Sig Name -> TcM Prag + 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 -tcPrag poly_id (SpecSig orig_name hs_ty inl) = tcSpecPrag poly_id hs_ty inl -tcPrag poly_id (SpecInstSig hs_ty) = tcSpecPrag poly_id hs_ty defaultInlineSpec -tcPrag poly_id (InlineSig v inl) = return (InlinePrag inl) +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 -tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag -tcSpecPrag poly_id hs_ty inl - = do { let name = idName poly_id +-- Commented out until bytestring library removes redundant pragmas +-- for packWith and unpackWith +-- ; unless (null spec_sigs || is_overloaded_id) warn_discarded_spec + + ; unless (null bad_sigs) warn_discarded_sigs + + ; return (poly_id', spec_prags) } + where + (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 + ppr_sigs sigs = vcat (map (ppr . getLoc) sigs) + +-------------- +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 -- subsequent error messages +recoveryCode :: [Name] -> (Name -> Maybe [Name]) + -> TcM (LHsBinds TcId, [Id]) recoveryCode binder_names sig_fn = do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names) ; poly_ids <- mapM mk_dummy binder_names - ; return ([], poly_ids) } + ; return (emptyBag, poly_ids) } where mk_dummy name | isJust (sig_fn name) = tcLookupId name -- Had signature; look it up @@ -465,6 +561,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 @@ -474,8 +576,15 @@ checkStrictBinds top_lvl rec_group mbind mono_tys infos bang_pat = anyBag (isBangHsBind . unLoc) mbind check_sig (_, Just sig, _) = checkTc (null (sig_tvs sig) && null (sig_theta sig)) (badStrictSig unlifted sig) - check_sig other = return () + 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:")) 4 (pprLHsBinds mbind) @@ -483,6 +592,7 @@ strictBindErr flavour unlifted mbind msg | unlifted = ptext (sLit "bindings for unlifted types") | otherwise = ptext (sLit "bang-pattern bindings") +badStrictSig :: Bool -> TcSigInfo -> SDoc badStrictSig unlifted sig = hang (ptext (sLit "Illegal polymorphic signature in") <+> msg) 4 (ppr sig) @@ -539,9 +649,9 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, [(name, Nothing, mono_id)]) } tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, - fun_matches = matches, bind_fvs = fvs })] + fun_matches = matches })] sig_fn -- Single function binding - non_rec + _ | 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 @@ -557,8 +667,14 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, -- Note that the scoped_tvs and the (sig_tvs sig) -- may have different Names. That's quite ok. + ; traceTc (text "tcMoonBinds" <+> ppr scoped_tvs $$ ppr tc_sig) ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $ tcMatchesFun mono_name inf matches mono_ty + -- Note that "mono_ty" might actually be a polymorphic type, + -- if the original function had a signature like + -- forall a. Eq a => forall b. Ord b => .... + -- But that's ok: tcMatchesFun can deal with that + -- It happens, too! See Note [Polymorphic methods] in TcClassDcl. ; let fun_bind' = FunBind { fun_id = L nm_loc mono_id, fun_infix = inf, fun_matches = matches', @@ -567,7 +683,7 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, ; return (unitBag (L b_loc fun_bind'), [(name, Just tc_sig, mono_id)]) } -tcMonoBinds binds sig_fn non_rec +tcMonoBinds binds sig_fn _ = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn)) binds -- Bring the monomorphic Ids, into scope for the RHSs @@ -623,17 +739,17 @@ tcLhs sig_fn (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = m mk_mono_ty (Just sig) = return (sig_tau sig) mk_mono_ty Nothing = newFlexiTyVarTy argTypeKind -tcLhs sig_fn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss }) +tcLhs sig_fn (PatBind { pat_lhs = pat, pat_rhs = grhss }) = do { mb_sigs <- mapM (tcInstSig_maybe sig_fn) names ; mono_pat_binds <- doptM Opt_MonoPatBinds - -- With -fmono-pat-binds, we do no generalisation of pattern bindings + -- With -XMonoPatBinds, we do no generalisation of pattern bindings -- But the signature can still be polymoprhic! -- data T = MkT (forall a. a->a) -- x :: forall a. a->a -- MkT x = -- The function get_sig_ty decides whether the pattern-bound variables - -- should have exactly the type in the type signature (-fmono-pat-binds), - -- or the instantiated version (-fmono-pat-binds) + -- should have exactly the type in the type signature (-XMonoPatBinds), + -- or the instantiated version (-XMonoPatBinds) ; let nm_sig_prs = names `zip` mb_sigs get_sig_ty | mono_pat_binds = idType . sig_id @@ -659,7 +775,7 @@ tcLhs sig_fn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss }) names = collectPatBinders pat -tcLhs sig_fn other_bind = pprPanic "tcLhs" (ppr other_bind) +tcLhs _ other_bind = pprPanic "tcLhs" (ppr other_bind) -- AbsBind, VarBind impossible ------------------- @@ -675,7 +791,7 @@ tcRhs (TcFunBind (_,_,mono_id) fun' inf matches) bind_fvs = placeHolderNames, fun_co_fn = co_fn, fun_tick = Nothing }) } -tcRhs bind@(TcPatBind _ pat' grhss pat_ty) +tcRhs (TcPatBind _ pat' grhss pat_ty) = do { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ tcGRHSsPat grhss pat_ty ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty, @@ -706,7 +822,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) } @@ -775,8 +891,10 @@ 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 [] = 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 @@ -793,7 +911,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")) } @@ -835,7 +953,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) @@ -855,7 +973,6 @@ checkDistinctTyVars sig_tvs <+> ptext (sLit "is unified with another quantified type variable") <+> quotes (ppr tidy_tv2) ; failWithTcM (env2, msg) } - where \end{code} @@ -1026,8 +1143,10 @@ mkTcSigFun :: [LSig Name] -> TcSigFun -- Precondition: no duplicates mkTcSigFun sigs = lookupNameEnv env where - env = mkNameEnv [(name, hsExplicitTvs lhs_ty) - | L span (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].) @@ -1081,6 +1200,9 @@ 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) ------------------- tcInstSig_maybe :: TcSigFun -> Name -> TcM (Maybe TcSigInfo) @@ -1088,10 +1210,10 @@ tcInstSig_maybe :: TcSigFun -> Name -> TcM (Maybe TcSigInfo) -- this signature is part of a multi-signature group tcInstSig_maybe sig_fn name = case sig_fn name of - Nothing -> return Nothing - Just scoped_tvs -> do { tc_sig <- tcInstSig False name - ; return (Just tc_sig) } - -- NB: the scoped_tvs may be non-empty, but we can + Nothing -> return Nothing + Just _scoped_tvs -> do { tc_sig <- tcInstSig False name + ; return (Just tc_sig) } + -- NB: the _scoped_tvs may be non-empty, but we can -- just ignore them. See Note [Scoped tyvars]. tcInstSig :: Bool -> Name -> TcM TcSigInfo @@ -1116,22 +1238,23 @@ tcInstSig :: Bool -> Name -> TcM TcSigInfo tcInstSig use_skols name = 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 = tcInstSigTyVars use_skols skol_info - ; (tvs, theta, tau) <- tcInstType inst_tyvars (idType poly_id) + ; let skol_info = SigSkol (FunSigCtxt name) + ; (tvs, theta, tau) <- tcInstSigType use_skols skol_info (idType poly_id) ; loc <- getInstLoc (SigOrigin skol_info) ; return (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_theta = theta, sig_tau = tau, 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 other = False + is_pat_bind _ = False ------------------- isRestrictedGroup :: DynFlags -> [LHsBind Name] -> TcSigFun -> Bool @@ -1146,10 +1269,12 @@ isRestrictedGroup dflags binds sig_fn unrestricted (VarBind { var_id = v }) = has_sig v unrestricted (FunBind { fun_id = v, fun_matches = matches }) = unrestricted_match matches || has_sig (unLoc v) + unrestricted (AbsBinds {}) + = panic "isRestrictedGroup/unrestricted AbsBinds" unrestricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = False -- No args => like a pattern binding - unrestricted_match other = True + unrestricted_match _ = True -- Some args => a function binding \end{code} @@ -1164,10 +1289,12 @@ isRestrictedGroup dflags binds sig_fn \begin{code} -- This one is called on LHS, when pat and grhss are both Name -- and on RHS, when pat is TcId and grhss is still Name +patMonoBindsCtxt :: OutputableBndr id => LPat id -> GRHSs Name -> SDoc patMonoBindsCtxt pat grhss = hang (ptext (sLit "In a pattern binding:")) 4 (pprPatBind pat grhss) ----------------------------------------------- +sigContextsCtxt :: TcSigInfo -> TcSigInfo -> SDoc sigContextsCtxt sig1 sig2 = vcat [ptext (sLit "When matching the contexts of the signatures for"), nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1), @@ -1179,20 +1306,24 @@ sigContextsCtxt sig1 sig2 ----------------------------------------------- +unboxedTupleErr :: Name -> Type -> SDoc unboxedTupleErr name ty = hang (ptext (sLit "Illegal binding of unboxed tuple")) 4 (ppr name <+> dcolon <+> ppr ty) ----------------------------------------------- +restrictedBindCtxtErr :: [Name] -> SDoc restrictedBindCtxtErr binder_names = hang (ptext (sLit "Illegal overloaded type signature(s)")) 4 (vcat [ptext (sLit "in a binding group for") <+> pprBinders binder_names, ptext (sLit "that falls under the monomorphism restriction")]) +genCtxt :: [Name] -> SDoc genCtxt binder_names = ptext (sLit "When generalising the type(s) for") <+> pprBinders binder_names -missingSigWarn False name ty = return () +missingSigWarn :: Bool -> Name -> Type -> TcM () +missingSigWarn False _ _ = return () missingSigWarn True name ty = do { env0 <- tcInitTidyEnv ; let (env1, tidy_ty) = tidyOpenType env0 ty