X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=7a7edb42cfa6a8c0f24c43ee15a4e3a3abd78ee7;hb=0cffd31b0f25c2a31ed6eff2c0c0b1b1a8a8d507;hp=c67eeef915ee2af42823c4c05801f86112c0fd98;hpb=9ffadf219cbc4f8ec57264786df936a3cee88aec;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index c67eeef..7a7edb4 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,7 +40,6 @@ import Bag import ErrUtils import Digraph import Maybes -import List import Util import BasicTypes import Outputable @@ -425,21 +423,24 @@ pragSigCtxt prag = hang (ptext (sLit "In the pragma")) 2 (ppr prag) tcPrag :: TcId -> Sig Name -> TcM Prag -- Pre-condition: the poly_id is zonked -- Reason: required by tcSubExp -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 _ sig = pprPanic "tcPrag" (ppr sig) - - -tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag -tcSpecPrag poly_id hs_ty inl +-- Most of the work of specialisation is done by +-- the desugarer, guided by the SpecPrag +tcPrag poly_id (SpecSig _ hs_ty inl) = 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 - +tcPrag poly_id (SpecInstSig hs_ty) + = do { let name = idName poly_id + ; (tyvars, theta, tau) <- tcHsInstHead hs_ty + ; let spec_ty = mkSigmaTy tyvars theta tau + ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty + ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty defaultInlineSpec) } + +tcPrag _ (InlineSig _ inl) = return (InlinePrag inl) +tcPrag _ sig = pprPanic "tcPrag" (ppr sig) + + -------------- -- If typechecking the binds fails, then return with each -- signature-less binder given type (forall a.a), to minimise @@ -475,6 +476,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 @@ -486,6 +493,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:")) @@ -724,7 +737,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) } @@ -795,7 +808,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 @@ -812,7 +826,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")) } @@ -854,7 +868,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) @@ -1147,10 +1161,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