X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=9bf8fafbaa3372fd6b940ad69e56e3e953ac3aef;hb=c7fa9243867d49177c9ebc7923588488dbd3a369;hp=ddf066b3d7b99152ab2c60e2a363f78aa078b57a;hpb=f16dbbbe59cf3aa19c5fd384560a1b89076d7bc8;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index ddf066b..9bf8faf 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -26,7 +26,6 @@ import TcHsType import TcPat import TcMType import TcType -import {- Kind parts of -} Type import Coercion import VarEnv import TysPrim @@ -41,7 +40,6 @@ import Bag import ErrUtils import Digraph import Maybes -import List import Util import BasicTypes import Outputable @@ -98,7 +96,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 @@ -151,7 +149,7 @@ 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 + ; ty_sigs = filter isTypeLSig sigs ; sig_fn = mkTcSigFun ty_sigs } ; poly_ids <- checkNoErrs (mapAndRecoverM tcTySig ty_sigs) @@ -203,15 +201,19 @@ 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 + | 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. @@ -219,16 +221,16 @@ tc_group poly_rec top_lvl sig_fn prag_fn (Recursive, binds) thing_inside -- 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 $ + ; (binds1,lie_binds,thing) <- bindLocalInsts top_lvl $ go (stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)) - ; return ([(Recursive, unionManyBags binds1)], thing) } + ; 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) @@ -236,17 +238,20 @@ tc_group poly_rec top_lvl sig_fn prag_fn (Recursive, binds) thing_inside tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive tc_haskell98 :: TopLevelFlag -> TcSigFun -> TcPragFun -> RecFlag - -> LHsBinds Name -> TcM a -> TcM ([LHsBinds TcId], a) + -> 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, _, 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 @@ -254,7 +259,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 @@ -289,7 +294,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 @@ -334,7 +339,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds mk_export (_, Just sig, mono_id) _ = ([], sig_id sig, mono_id, []) -- ToDo: prags for unlifted bindings - ; return ( [unitBag $ L loc $ AbsBinds [] [] exports binds'], + ; return ( unitBag $ L loc $ AbsBinds [] [] exports binds', [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked else do -- The normal lifted case: GENERALISE @@ -355,7 +360,7 @@ 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 } } @@ -421,8 +426,7 @@ tcPrag :: TcId -> Sig Name -> TcM Prag tcPrag poly_id (SpecSig _ hs_ty inl) = tcSpecPrag poly_id hs_ty inl tcPrag poly_id (SpecInstSig hs_ty) = tcSpecPrag poly_id hs_ty defaultInlineSpec tcPrag _ (InlineSig _ inl) = return (InlinePrag inl) -tcPrag _ (FixSig {}) = panic "tcPrag FixSig" -tcPrag _ (TypeSig {}) = panic "tcPrag TypeSig" +tcPrag _ sig = pprPanic "tcPrag" (ppr sig) tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag @@ -439,11 +443,11 @@ tcSpecPrag poly_id hs_ty inl -- signature-less binder given type (forall a.a), to minimise -- subsequent error messages recoveryCode :: [Name] -> (Name -> Maybe [Name]) - -> TcM ([Bag (LHsBindLR Id Var)], [Id]) + -> 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 @@ -469,6 +473,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 @@ -480,6 +490,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:")) @@ -718,7 +734,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) } @@ -789,7 +805,7 @@ 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 { mapM_ unify_ctxt sigs ; theta <- zonkTcThetaType (sig_theta sig1) ; newDictBndrs (sig_loc sig1) theta } where @@ -806,7 +822,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")) } @@ -848,7 +864,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) @@ -1038,8 +1054,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].) @@ -1093,6 +1111,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) ------------------- @@ -1137,10 +1157,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