From edeee10702955ca3c53444f2f328b4cce0ab3e32 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Fri, 24 Sep 2010 15:58:15 +0000 Subject: [PATCH] Fix an egregious bug: INLINE pragmas on monomorphic Ids were being ignored I had do to some refactoring to make this work nicely but now it does. I can't think how this escaped our attention for so long! --- compiler/deSugar/DsBinds.lhs | 85 +---------------- compiler/typecheck/TcBinds.lhs | 187 ++++++++++++------------------------- compiler/typecheck/TcClassDcl.lhs | 6 +- compiler/typecheck/TcInstDcls.lhs | 6 +- compiler/typecheck/TcPat.lhs | 77 +++++++++++---- 5 files changed, 133 insertions(+), 228 deletions(-) diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 17333af..b5b58fe 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -107,91 +107,16 @@ dsHsBind _ (FunBind { fun_id = L _ fun, fun_matches = matches = do { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches ; body' <- mkOptTickBox tick body ; wrap_fn' <- dsHsWrapper co_fn - ; return (unitOL (fun, wrap_fn' (mkLams args body'))) } + ; let rhs = wrap_fn' (mkLams args body') + ; return (unitOL (makeCorePair fun False 0 rhs)) } dsHsBind _ (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) = do { body_expr <- dsGuarded grhss ty ; sel_binds <- mkSelectorBinds pat body_expr + -- We silently ignore inline pragmas; no makeCorePair + -- Not so cool, but really doesn't matter ; return (toOL sel_binds) } -{- -dsHsBind auto_scc (AbsBinds { abs_tvs = [], abs_ev_vars = [] - , abs_exports = exports, abs_ev_binds = ev_binds - , abs_binds = binds }) - = do { bind_prs <- ds_lhs_binds NoSccs binds - ; ds_ev_binds <- dsTcEvBinds ev_binds - - ; let core_prs = addEvPairs ds_ev_binds bind_prs - env = mkABEnv exports - do_one (lcl_id, rhs) - | Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id - = do { let rhs' = addAutoScc auto_scc gbl_id rhs - ; (spec_binds, rules) <- dsSpecs gbl_id (Let (Rec core_prs) rhs') spec_prags - -- See Note [Specialising in no-dict case] - ; let gbl_id' = addIdSpecialisations gbl_id rules - main_bind = makeCorePair gbl_id' False 0 rhs' - ; return (main_bind : spec_binds) } - - | otherwise = return [(lcl_id, rhs)] - - locals' = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports] - -- Note [Rules and inlining] - ; export_binds <- mapM do_one core_prs - ; return (concat export_binds ++ locals' ++ rest) } - -- No Rec needed here (contrast the other AbsBinds cases) - -- because we can rely on the enclosing dsBind to wrap in Rec - - -dsHsBind auto_scc rest (AbsBinds { abs_tvs = tyvars, abs_ev_vars = [] - , abs_exports = exports, abs_ev_binds = ev_binds - , abs_binds = binds }) - | opt_DsMultiTyVar -- This (static) debug flag just lets us - -- switch on and off this optimisation to - -- see if it has any impact; it is on by default - , allOL isLazyEvBind ev_binds - = -- Note [Abstracting over tyvars only] - do { bind_prs <- ds_lhs_binds NoSccs binds - ; ds_ev_binds <- dsTcEvBinds ev_binds - - ; let core_prs = addEvPairs ds_ev_binds bind_prs - arby_env = mkArbitraryTypeEnv tyvars exports - bndrs = mkVarSet (map fst core_prs) - - add_lets | core_prs `lengthExceeds` 10 = add_some - | otherwise = mkLets - add_some lg_binds rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds - , b `elemVarSet` fvs] rhs - where - fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs - - env = mkABEnv exports - mk_lg_bind lcl_id gbl_id tyvars - = NonRec (setIdInfo lcl_id vanillaIdInfo) - -- Nuke the IdInfo so that no old unfoldings - -- confuse use (it might mention something not - -- even in scope at the new site - (mkTyApps (Var gbl_id) (mkTyVarTys tyvars)) - - do_one lg_binds (lcl_id, rhs) - | Just (id_tvs, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id - = do { let rhs' = addAutoScc auto_scc gbl_id $ - mkLams id_tvs $ - mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv)) - | tv <- tyvars, not (tv `elem` id_tvs)] $ - add_lets lg_binds rhs - ; (spec_binds, rules) <- dsSpecs gbl_id rhs' spec_prags - ; let gbl_id' = addIdSpecialisations gbl_id rules - main_bind = makeCorePair gbl_id' False 0 rhs' - ; return (mk_lg_bind lcl_id gbl_id' id_tvs, main_bind : spec_binds) } - | otherwise - = do { non_exp_gbl_id <- newUniqueId lcl_id (mkForAllTys tyvars (idType lcl_id)) - ; return (mk_lg_bind lcl_id non_exp_gbl_id tyvars, - [(non_exp_gbl_id, mkLams tyvars (add_lets lg_binds rhs))]) } - - ; (_, core_prs') <- fixDs (\ ~(lg_binds, _) -> mapAndUnzipM (do_one lg_binds) core_prs) - ; return (concat core_prs' ++ rest) } --} - -- A common case: one exported variable -- Non-recursive bindings come through this way -- So do self-recursive bindings, and recursive bindings @@ -417,7 +342,7 @@ This does not happen in the same way to polymorphic binds, because they desugar to M.f = /\a. let f_lcl = ...f_lcl... in f_lcl Although I'm a bit worried about whether full laziness might -float the f_lcl binding out and then inline M.f at its call site -} +float the f_lcl binding out and then inline M.f at its call site Note [Specialising in no-dict case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index abd04a6..0db76d1 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -7,7 +7,7 @@ \begin{code} module TcBinds ( tcLocalBinds, tcTopBinds, tcHsBootSigs, tcPolyBinds, - PragFun, tcPrags, mkPragFun, + PragFun, tcSpecPrags, mkPragFun, TcSigInfo(..), SigFun, mkSigFun, badBootDeclErr ) where @@ -43,7 +43,6 @@ import BasicTypes import Outputable import FastString -import Data.List( partition ) import Control.Monad \end{code} @@ -326,9 +325,9 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list ; let plan = decideGeneralisationPlan dflags top_lvl binder_names bind_list tc_sig_fn ; traceTc "Generalisation plan" (ppr plan) ; (binds, poly_ids) <- case plan of - NoGen -> tcPolyNoGen tc_sig_fn prag_fn rec_group rec_tc bind_list - InferGen mono -> tcPolyInfer top_lvl mono tc_sig_fn prag_fn rec_group rec_tc bind_list - CheckGen sig -> tcPolyCheck sig prag_fn rec_group rec_tc bind_list + NoGen -> tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list + InferGen mono -> tcPolyInfer top_lvl mono tc_sig_fn prag_fn rec_tc bind_list + CheckGen sig -> tcPolyCheck sig prag_fn rec_tc bind_list -- Check whether strict bindings are ok -- These must be non-recursive etc, and are not generalised @@ -342,17 +341,18 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list -- TODO: location a bit awkward, but the mbinds have been -- dependency analysed and may no longer be adjacent +------------------ tcPolyNoGen :: TcSigFun -> PragFun - -> RecFlag -- Whether the group is really recursive -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId]) -- No generalisation whatsoever -tcPolyNoGen tc_sig_fn prag_fn rec_group rec_tc bind_list - = do { (binds', mono_infos) <- tcMonoBinds tc_sig_fn True rec_tc bind_list +tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list + = do { (binds', mono_infos) <- tcMonoBinds tc_sig_fn (LetGblBndr prag_fn) + rec_tc bind_list ; mono_ids' <- mapM tc_mono_info mono_infos ; return (binds', mono_ids') } where @@ -360,16 +360,15 @@ tcPolyNoGen tc_sig_fn prag_fn rec_group rec_tc bind_list = do { mono_ty' <- zonkTcTypeCarefully (idType mono_id) -- Zonk, mainly to expose unboxed types to checkStrictBinds ; let mono_id' = setIdType mono_id mono_ty' - ; (mono_id'', _specs) <- tcPrags rec_group False False - mono_id' (prag_fn name) - ; return mono_id'' } - -- NB: tcPrags generates and error message for + ; _specs <- tcSpecPrags False mono_id' (prag_fn name) + ; return mono_id' } + -- NB: tcPrags generates error messages for -- specialisation pragmas for non-overloaded sigs + -- Indeed that is why we call it here! -- So we can safely ignore _specs ------------------ tcPolyCheck :: TcSigInfo -> PragFun - -> RecFlag -- Whether the group is really recursive -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures -> [LHsBind Name] @@ -379,16 +378,16 @@ tcPolyCheck :: TcSigInfo -> PragFun -- it has a signature, tcPolyCheck sig@(TcSigInfo { sig_id = id, sig_tvs = tvs, sig_scoped = scoped , sig_theta = theta, sig_loc = loc }) - prag_fn rec_group rec_tc bind_list + prag_fn rec_tc bind_list = do { ev_vars <- newEvVars theta ; let skol_info = SigSkol (FunSigCtxt (idName id)) ; (ev_binds, (binds', [mono_info])) <- checkConstraints skol_info emptyVarSet tvs ev_vars $ tcExtendTyVarEnv2 (scoped `zip` mkTyVarTys tvs) $ - tcMonoBinds (\_ -> Just sig) False rec_tc bind_list + tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list - ; export <- mkExport rec_group False prag_fn tvs theta mono_info + ; export <- mkExport prag_fn tvs theta mono_info ; let (_, poly_id, _, _) = export abs_bind = L loc $ AbsBinds @@ -397,19 +396,19 @@ tcPolyCheck sig@(TcSigInfo { sig_id = id, sig_tvs = tvs, sig_scoped = scoped , abs_exports = [export], abs_binds = binds' } ; return (unitBag abs_bind, [poly_id]) } +------------------ tcPolyInfer :: TopLevelFlag -> Bool -- True <=> apply the monomorphism restriction -> TcSigFun -> PragFun - -> RecFlag -- Whether the group is really recursive -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId]) -tcPolyInfer top_lvl mono sig_fn prag_fn rec_group rec_tc bind_list +tcPolyInfer top_lvl mono sig_fn prag_fn rec_tc bind_list = do { ((binds', mono_infos), wanted) <- getConstraints $ - tcMonoBinds sig_fn False rec_tc bind_list + tcMonoBinds sig_fn LetLclBndr rec_tc bind_list ; unifyCtxts [sig | (_, Just sig, _) <- mono_infos] @@ -420,8 +419,7 @@ tcPolyInfer top_lvl mono sig_fn prag_fn rec_group rec_tc bind_list ; (qtvs, givens, ev_binds) <- simplifyInfer mono tau_tvs wanted - ; exports <- mapM (mkExport rec_group (length mono_infos > 1) - prag_fn qtvs (map evVarPred givens)) + ; exports <- mapM (mkExport prag_fn qtvs (map evVarPred givens)) mono_infos ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports] @@ -437,10 +435,7 @@ tcPolyInfer top_lvl mono sig_fn prag_fn rec_group rec_tc bind_list -------------- -mkExport :: RecFlag - -> Bool -- More than one variable is bound, so we'll desugar to - -- a tuple, so INLINE pragmas won't work - -> PragFun -> [TyVar] -> TcThetaType +mkExport :: PragFun -> [TyVar] -> TcThetaType -> MonoBindInfo -> TcM ([TyVar], Id, Id, TcSpecPrags) -- mkExport generates exports with @@ -454,17 +449,19 @@ mkExport :: RecFlag -- Pre-condition: the inferred_tvs are already zonked -mkExport rec_group multi_bind prag_fn inferred_tvs theta +mkExport prag_fn inferred_tvs theta (poly_name, mb_sig, mono_id) = do { (tvs, poly_id) <- mk_poly_id mb_sig -- poly_id has a zonked type - ; (poly_id', spec_prags) <- tcPrags rec_group multi_bind (notNull theta) - poly_id (prag_fn poly_name) + ; poly_id' <- addInlinePrags poly_id prag_sigs + + ; spec_prags <- tcSpecPrags (notNull theta) poly_id prag_sigs -- tcPrags requires a zonked poly_id ; return (tvs, poly_id', mono_id, SpecPrags spec_prags) } where + prag_sigs = prag_fn poly_name poly_ty = mkSigmaTy inferred_tvs theta (idType mono_id) mk_poly_id Nothing = do { poly_ty' <- zonkTcTypeCarefully poly_ty @@ -504,89 +501,43 @@ 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]) +------------------ +tcSpecPrags :: Bool -- True <=> function is overloaded + -> Id -> [LSig Name] + -> TcM [Located TcSpecPrag] -- Add INLINE and SPECIALSE 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 _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 - +tcSpecPrags is_overloaded_id poly_id prag_sigs + = do { unless (null spec_sigs || is_overloaded_id) warn_discarded_spec ; unless (null bad_sigs) warn_discarded_sigs - - ; return (poly_id', spec_prags) } + ; mapM (wrapLocM tc_spec) spec_sigs } where - (inl_sigs, other_sigs) = partition isInlineLSig prag_sigs - (spec_sigs, bad_sigs) = partition isSpecLSig other_sigs + spec_sigs = filter isSpecLSig prag_sigs + bad_sigs = filter is_bad_sig prag_sigs + is_bad_sig s = not (isSpecLSig s || isInlineLSig s) + + name = idName poly_id + poly_ty = idType poly_id + sig_ctxt = FunSigCtxt name + origin = SpecPragOrigin name + skol_info = SigSkol sig_ctxt + + tc_spec prag@(SpecSig _ hs_ty inl) + = addErrCtxt (spec_ctxt prag) $ + do { spec_ty <- tcHsSigType sig_ctxt hs_ty + ; wrap <- tcSubType origin skol_info poly_ty spec_ty + ; return (SpecPrag wrap inl) } + tc_spec sig = pprPanic "tcSpecPrag" (ppr sig) 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 - sig_ctxt = FunSigCtxt name - ; spec_ty <- tcHsSigType sig_ctxt hs_ty - ; wrap <- tcSubType (SpecPragOrigin name) (SigSkol sig_ctxt) - (idType poly_id) spec_ty - ; return (SpecPrag wrap 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 @@ -617,8 +568,7 @@ forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar) The signatures have been dealt with already. \begin{code} -tcMonoBinds :: TcSigFun - -> Bool -- True <=> no generalisation will be done for this binding +tcMonoBinds :: TcSigFun -> LetBndrSpec -> RecFlag -- Whether the binding is recursive for typechecking purposes -- i.e. the binders are mentioned in their RHSs, and -- we are not resuced by a type signature @@ -639,7 +589,7 @@ tcMonoBinds sig_fn no_gen is_rec setSrcSpan b_loc $ do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name inf matches) - ; mono_id <- newLetBndr no_gen name rhs_ty + ; mono_id <- newNoSigLetBndr no_gen name rhs_ty ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf, fun_matches = matches', bind_fvs = fvs, fun_co_fn = co_fn, fun_tick = Nothing })), @@ -677,7 +627,7 @@ tcMonoBinds sig_fn no_gen _ binds -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't data TcMonoBind -- Half completed; LHS done, RHS not done - = TcFunBind MonoBindInfo (Located TcId) Bool (MatchGroup Name) + = TcFunBind MonoBindInfo SrcSpan Bool (MatchGroup Name) | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType type MonoBindInfo = (Name, Maybe TcSigInfo, TcId) @@ -687,12 +637,15 @@ type MonoBindInfo = (Name, Maybe TcSigInfo, TcId) getMonoType :: MonoBindInfo -> TcTauType getMonoType (_,_,mono_id) = idType mono_id -tcLhs :: TcSigFun -> Bool -> HsBind Name -> TcM TcMonoBind +tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches }) - = do { mono_id <- newLhsBndr mb_sig no_gen name - ; return (TcFunBind (name, mb_sig, mono_id) (L nm_loc mono_id) inf matches) } - where - mb_sig = sig_fn name + | Just sig <- sig_fn name + = do { mono_id <- newSigLetBndr no_gen name sig + ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) } + | otherwise + = do { mono_ty <- newFlexiTyVarTy argTypeKind + ; mono_id <- newNoSigLetBndr no_gen name mono_ty + ; return (TcFunBind (name, Nothing, mono_id) nm_loc inf matches) } tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss }) = do { let tc_pat exp_ty = tcLetPat sig_fn no_gen pat exp_ty $ @@ -712,28 +665,17 @@ tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss }) tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind) -- AbsBind, VarBind impossible ------------------ -newLhsBndr :: Maybe TcSigInfo -> Bool -> Name -> TcM TcId --- cf TcPat.tcPatBndr (LetPat case) -newLhsBndr (Just sig) no_gen name - | no_gen = return (sig_id sig) - | otherwise = do { mono_name <- newLocalName name - ; return (mkLocalId mono_name (sig_tau sig)) } - -newLhsBndr Nothing no_gen name - = do { mono_ty <- newFlexiTyVarTy argTypeKind - ; newLetBndr no_gen name mono_ty } - ------------------- tcRhs :: TcMonoBind -> TcM (HsBind TcId) -- When we are doing pattern bindings, or multiple function bindings at a time -- we *don't* bring any scoped type variables into scope -- Wny not? They are not completely rigid. -- That's why we have the special case for a single FunBind in tcMonoBinds -tcRhs (TcFunBind (_,_,mono_id) fun' inf matches) +tcRhs (TcFunBind (_,_,mono_id) loc inf matches) = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) inf matches (idType mono_id) - ; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches' + ; return (FunBind { fun_id = L loc mono_id, fun_infix = inf + , fun_matches = matches' , fun_co_fn = co_fn , bind_fvs = placeHolderNames, fun_tick = Nothing }) } @@ -897,8 +839,6 @@ Then we get in fm - - %************************************************************************ %* * Signatures @@ -1078,9 +1018,6 @@ decideGeneralisationPlan dflags top_lvl _bndrs binds sig_fn && isNotTopLevel top_lvl) = NoGen | otherwise = InferGen mono_restriction --- | all no_sig bndrs = InferGen mono_restriction --- | otherwise = NoGen -- A mixture of function --- -- and pattern bindings where mono_pat_binds = xopt Opt_MonoPatBinds dflags && any (is_pat_bind . unLoc) binds diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 85a9431..a4a00c9 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -19,6 +19,7 @@ import RnHsSyn import RnExpr import Inst import InstEnv +import TcPat( addInlinePrags ) import TcEnv import TcBinds import TcUnify @@ -216,9 +217,10 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info) dm_id = mkDefaultMethodId sel_id dm_name local_dm_type = instantiateMethod clas sel_id (mkTyVarTys tyvars) local_dm_id = mkLocalId local_dm_name local_dm_type + prags = prag_fn sel_name - ; (dm_id_w_inline, spec_prags) - <- tcPrags NonRecursive False True dm_id (prag_fn sel_name) + ; dm_id_w_inline <- addInlinePrags dm_id prags + ; spec_prags <- tcSpecPrags True dm_id prags ; warnTc (not (null spec_prags)) (ptext (sLit "Ignoring SPECIALISE pragmas on default method") diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 3f45db3..a76d87b 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -12,6 +12,7 @@ import HsSyn import TcBinds import TcTyClsDecls import TcClassDcl +import TcPat( addInlinePrags ) import TcRnMonad import TcMType import TcType @@ -838,8 +839,9 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys = add_meth_ctxt sel_id generated_code rn_bind $ do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id - ; (meth_id1, spec_prags) <- tcPrags NonRecursive False True - meth_id (prag_fn (idName sel_id)) + ; let prags = prag_fn (idName sel_id) + ; meth_id1 <- addInlinePrags meth_id prags + ; spec_prags <- tcSpecPrags True meth_id prags ; bind <- tcInstanceMethodBody InstSkol tyvars dfun_ev_vars diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 49d0c8a..1e391de 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -6,8 +6,9 @@ TcPat: Typechecking patterns \begin{code} -module TcPat ( tcLetPat, TcSigFun, TcSigInfo(..) - , tcPat, tcPats, newLetBndr +module TcPat ( tcLetPat, TcSigFun, TcSigInfo(..), TcPragFun + , LetBndrSpec(..), addInlinePrags, warnPrags + , tcPat, tcPats, newNoSigLetBndr, newSigLetBndr , addDataConStupidTheta, badFieldCon, polyPatSig ) where #include "HsVersions.h" @@ -51,16 +52,15 @@ import Control.Monad %************************************************************************ \begin{code} -tcLetPat :: (Name -> Maybe TcSigInfo) - -> Bool -- True <=> monomorphic +tcLetPat :: TcSigFun -> LetBndrSpec -> LPat Name -> TcSigmaType -> TcM a -> TcM (LPat TcId, a) -tcLetPat sig_fn is_mono pat pat_ty thing_inside +tcLetPat sig_fn no_gen pat pat_ty thing_inside = tc_lpat pat pat_ty penv thing_inside where penv = PE { pe_res_tvs = emptyVarSet, pe_lazy = True - , pe_ctxt = LetPat sig_fn is_mono } + , pe_ctxt = LetPat sig_fn no_gen } ----------------- tcPats :: HsMatchContext Name @@ -121,9 +121,16 @@ data PatCtxt | LetPat -- Used only for let(rec) bindings -- See Note [Let binders] - TcSigFun -- Tells type sig if any - Bool -- True <=> no generalisation of this let - + TcSigFun -- Tells type sig if any + LetBndrSpec -- True <=> no generalisation of this let + +data LetBndrSpec + = LetLclBndr -- The binder is just a local one; + -- an AbsBinds will provide the global version + + | LetGblBndr TcPragFun -- There isn't going to be an AbsBinds; + -- here is the inline-pragma information + makeLazy :: PatEnv -> PatEnv makeLazy penv = penv { pe_lazy = True } @@ -132,7 +139,8 @@ patSigCtxt (PE { pe_ctxt = LetPat {} }) = BindPatSigCtxt patSigCtxt (PE { pe_ctxt = LamPat {} }) = LamPatSigCtxt --------------- -type TcSigFun = Name -> Maybe TcSigInfo +type TcPragFun = Name -> [LSig Name] +type TcSigFun = Name -> Maybe TcSigInfo data TcSigInfo = TcSigInfo { @@ -205,30 +213,61 @@ tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (CoercionI, TcId) -- tcPatBndr (PE { pe_ctxt = LetPat lookup_sig no_gen}) bndr_name pat_ty | Just sig <- lookup_sig bndr_name - = do { bndr_id <- if no_gen then return (sig_id sig) - else do { mono_name <- newLocalName bndr_name - ; return (Id.mkLocalId mono_name (sig_tau sig)) } + = do { bndr_id <- newSigLetBndr no_gen bndr_name sig ; coi <- unifyPatType (idType bndr_id) pat_ty ; return (coi, bndr_id) } | otherwise - = do { bndr_id <- newLetBndr no_gen bndr_name pat_ty + = do { bndr_id <- newNoSigLetBndr no_gen bndr_name pat_ty ; return (IdCo pat_ty, bndr_id) } tcPatBndr (PE { pe_ctxt = _lam_or_proc }) bndr_name pat_ty = do { bndr <- mkLocalBinder bndr_name pat_ty ; return (IdCo pat_ty, bndr) } -newLetBndr :: Bool -> Name -> TcType -> TcM TcId +------------ +newSigLetBndr :: LetBndrSpec -> Name -> TcSigInfo -> TcM TcId +newSigLetBndr LetLclBndr name sig + = do { mono_name <- newLocalName name + ; mkLocalBinder mono_name (sig_tau sig) } +newSigLetBndr (LetGblBndr prags) name sig + = addInlinePrags (sig_id sig) (prags name) + +------------ +newNoSigLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId -- In the polymorphic case (no_gen = False), generate a "monomorphic version" -- of the Id; the original name will be bound to the polymorphic version -- by the AbsBinds -- In the monomorphic case there is no AbsBinds, and we use the original -- name directly -newLetBndr no_gen name ty - | no_gen = mkLocalBinder name ty - | otherwise = do { mono_name <- newLocalName name - ; mkLocalBinder mono_name ty } +newNoSigLetBndr LetLclBndr name ty + =do { mono_name <- newLocalName name + ; mkLocalBinder mono_name ty } +newNoSigLetBndr (LetGblBndr prags) name ty + = do { id <- mkLocalBinder name ty + ; addInlinePrags id (prags name) } + +---------- +addInlinePrags :: TcId -> [LSig Name] -> TcM TcId +addInlinePrags poly_id prags + = tc_inl inl_sigs + where + inl_sigs = filter isInlineLSig prags + 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" + + warn_dup_inline = warnPrags poly_id inl_sigs $ + ptext (sLit "Duplicate INLINE pragmas for") + +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) ----------------- mkLocalBinder :: Name -> TcType -> TcM TcId -- 1.7.10.4