From: simonpj@microsoft.com Date: Wed, 6 Jan 2010 16:06:03 +0000 (+0000) Subject: Improve the handling of default methods X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=77166b1729061531eeb77c33f4d3b2581f7d4c41 Improve the handling of default methods See the long Note [INLINE and default methods]. This patch changes a couple of data types, with a knock-on effect on the format of interface files. A lot of files get touched, but is a relatively minor change. The main tiresome bit is the extra plumbing to communicate default methods between the type checker and the desugarer. --- diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index fa7ead0..b151f5b 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -58,7 +58,7 @@ module BasicTypes( Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive, RuleMatchInfo(..), isConLike, isFunLike, InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma, - isDefaultInlinePragma, isInlinePragma, + isDefaultInlinePragma, isInlinePragma, inlinePragmaSat, inlinePragmaActivation, inlinePragmaRuleMatchInfo, setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, @@ -597,6 +597,8 @@ data InlinePragma -- Note [InlinePragma] = InlinePragma { inl_inline :: Bool -- True <=> INLINE, -- False <=> no pragma at all, or NOINLINE + , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n + -- explicit (non-type, non-dictionary) args , inl_act :: Activation -- Says during which phases inlining is allowed , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? } deriving( Eq ) @@ -664,14 +666,14 @@ isFunLike _ = False defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma :: InlinePragma -defaultInlinePragma - = InlinePragma { inl_act = AlwaysActive, inl_rule = FunLike, inl_inline = False } -alwaysInlinePragma - = InlinePragma { inl_act = AlwaysActive, inl_rule = FunLike, inl_inline = True } -neverInlinePragma - = InlinePragma { inl_act = NeverActive, inl_rule = FunLike, inl_inline = False } -dfunInlinePragma - = InlinePragma { inl_act = AlwaysActive, inl_rule = ConLike, inl_inline = False } +defaultInlinePragma = InlinePragma { inl_act = AlwaysActive + , inl_rule = FunLike + , inl_inline = False + , inl_sat = Nothing } + +alwaysInlinePragma = defaultInlinePragma { inl_inline = True } +neverInlinePragma = defaultInlinePragma { inl_act = NeverActive } +dfunInlinePragma = defaultInlinePragma { inl_rule = ConLike } isDefaultInlinePragma :: InlinePragma -> Bool @@ -683,6 +685,9 @@ isDefaultInlinePragma (InlinePragma { inl_act = activation isInlinePragma :: InlinePragma -> Bool isInlinePragma prag = inl_inline prag +inlinePragmaSat :: InlinePragma -> Maybe Arity +inlinePragmaSat = inl_sat + inlinePragmaActivation :: InlinePragma -> Activation inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation @@ -706,11 +711,14 @@ instance Outputable RuleMatchInfo where ppr FunLike = ptext (sLit "FUNLIKE") instance Outputable InlinePragma where - ppr (InlinePragma { inl_inline = inline, inl_act = activation, inl_rule = info }) - = pp_inline <+> pp_info <+> pp_activation + ppr (InlinePragma { inl_inline = inline, inl_act = activation + , inl_rule = info, inl_sat = mb_arity }) + = pp_inline <> pp_sat <+> pp_info <+> pp_activation where pp_inline | inline = ptext (sLit "INLINE") | otherwise = ptext (sLit "NOINLINE") + pp_sat | Just ar <- mb_arity = braces (int ar) + | otherwise = empty pp_info | isFunLike info = empty | otherwise = ppr info pp_activation diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index b5525dc..16c45b7 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -345,7 +345,7 @@ mkDataConIds wrap_name wkr_name data_con -- ...(let w = C x in ...(w p q)...)... -- we want to see that w is strict in its two arguments - wrap_unf = mkInlineRule needSaturated wrap_rhs (length dict_args + length id_args) + wrap_unf = mkInlineRule wrap_rhs (Just (length dict_args + length id_args)) wrap_rhs = mkLams wrap_tvs $ mkLams eq_args $ mkLams dict_args $ mkLams id_args $ diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index c98fc01..83692a8 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -474,6 +474,7 @@ data UnfoldingGuidance -- See Note [INLINE for small functions] in CoreUnfold ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated ug_boring_ok :: Bool -- True <=> ok to inline even if the context is boring + -- So True,True means "always" } | UnfIfGoodArgs { -- Arose from a normal Id; the info here is the diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index fc31d5a..7d04154 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -43,6 +43,7 @@ import PprCore () -- Instances import OccurAnal import CoreSubst hiding( substTy ) import CoreFVs ( exprFreeVars ) +import CoreArity ( manifestArity ) import CoreUtils import Id import DataCon @@ -140,13 +141,17 @@ mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolde expr 0 -- Arity of unfolding doesn't matter (UnfWhen unSaturatedOk boringCxtOk) -mkInlineRule :: Bool -> CoreExpr -> Arity -> Unfolding -mkInlineRule unsat_ok expr arity +mkInlineRule :: CoreExpr -> Maybe Arity -> Unfolding +mkInlineRule expr mb_arity = mkCoreUnfolding True InlineRule -- Note [Top-level flag on inline rules] expr' arity (UnfWhen unsat_ok boring_ok) where expr' = simpleOptExpr expr + (unsat_ok, arity) = case mb_arity of + Nothing -> (unSaturatedOk, manifestArity expr') + Just ar -> (needSaturated, ar) + boring_ok = case calcUnfoldingGuidance True -- Treat as cheap False -- But not bottoming (arity+1) expr' of @@ -184,7 +189,6 @@ calcUnfoldingGuidance expr_is_cheap top_bot bOMB_OUT_SIZE expr | uncondInline n_val_bndrs (iBox size) , expr_is_cheap -> UnfWhen unSaturatedOk boringCxtOk -- Note [INLINE for small functions] - | top_bot -- See Note [Do not inline top-level bottoming functions] -> UnfNever @@ -626,9 +630,11 @@ actual arguments. \begin{code} couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool couldBeSmallEnoughToInline threshold rhs - = case calcUnfoldingGuidance False False threshold rhs of - (_, UnfNever) -> False - _ -> True + = case sizeExpr (iUnbox threshold) [] body of + TooBig -> False + _ -> True + where + (_, body) = collectBinders rhs ---------------- smallEnoughToInline :: Unfolding -> Bool diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index f6fc5a3..9e29c96 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -142,12 +142,10 @@ dsHsBind _ rest dsHsBind auto_scc rest (AbsBinds [] [] exports binds) = do { core_prs <- ds_lhs_binds NoSccs binds ; let env = mkABEnv exports - ar_env = mkArityEnv binds do_one (lcl_id, rhs) | Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id - = WARN( not (null spec_prags), ppr gbl_id $$ ppr spec_prags ) -- Not overloaded - makeCorePair gbl_id (lookupArity ar_env lcl_id) - (addAutoScc auto_scc gbl_id rhs) + = WARN( hasSpecPrags spec_prags, pprTcSpecPrags gbl_id spec_prags ) -- Not overloaded + makeCorePair gbl_id False 0 (addAutoScc auto_scc gbl_id rhs) | otherwise = (lcl_id, rhs) @@ -217,9 +215,7 @@ dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds) where fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs - ar_env = mkArityEnv binds env = mkABEnv exports - mk_lg_bind lcl_id gbl_id tyvars = NonRec (setIdInfo lcl_id vanillaIdInfo) -- Nuke the IdInfo so that no old unfoldings @@ -229,14 +225,14 @@ dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds) do_one lg_binds (lcl_id, rhs) | Just (id_tvs, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id - = WARN( not (null spec_prags), ppr gbl_id $$ ppr spec_prags ) -- Not overloaded + = WARN( hasSpecPrags spec_prags, pprTcSpecPrags gbl_id spec_prags ) -- Not overloaded (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 in return (mk_lg_bind lcl_id gbl_id id_tvs, - makeCorePair gbl_id (lookupArity ar_env lcl_id) rhs')) + makeCorePair gbl_id False 0 rhs')) | 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, @@ -254,25 +250,24 @@ dsHsBind auto_scc rest = ASSERT( all (`elem` tyvars) all_tyvars ) do { core_prs <- ds_lhs_binds NoSccs binds - ; let -- Always treat the binds as recursive, because the typechecker - -- makes rather mixed-up dictionary bindings + ; let -- Always treat the binds as recursive, because the + -- typechecker makes rather mixed-up dictionary bindings core_bind = Rec core_prs - inl_arity = lookupArity (mkArityEnv binds) local ; (spec_binds, rules) <- dsSpecs all_tyvars dicts tyvars global - local inl_arity core_bind prags + local core_bind prags ; let global' = addIdSpecialisations global rules rhs = addAutoScc auto_scc global $ mkLams tyvars $ mkLams dicts $ Let core_bind (Var local) - main_bind = makeCorePair global' (inl_arity + dictArity dicts) rhs + main_bind = makeCorePair global' (isDefaultMethod prags) + (dictArity dicts) rhs ; return (main_bind : spec_binds ++ rest) } dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds) = do { core_prs <- ds_lhs_binds NoSccs binds ; let env = mkABEnv exports - ar_env = mkArityEnv binds do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id = (lcl_id, addAutoScc auto_scc gbl_id rhs) | otherwise = (lcl_id,rhs) @@ -297,7 +292,7 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds) ; locals' <- newSysLocalsDs (map substitute local_tys) ; tup_id <- newSysLocalDs (substitute tup_ty) ; (spec_binds, rules) <- dsSpecs all_tyvars dicts tyvars global local - (lookupArity ar_env local) core_bind + core_bind spec_prags ; let global' = addIdSpecialisations global rules rhs = mkLams tyvars $ mkLams dicts $ @@ -317,50 +312,40 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds) (concat export_binds_s ++ rest)) } ------------------------ -makeCorePair :: Id-> Arity -> CoreExpr -> (Id, CoreExpr) -makeCorePair gbl_id arity rhs - | isInlinePragma (idInlinePragma gbl_id) +makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr) +makeCorePair gbl_id is_default_method dict_arity rhs + | is_default_method -- Default methods are *always* inlined + = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs) + + | not (isInlinePragma inline_prag) + = (gbl_id, rhs) + + | Just arity <- inlinePragmaSat inline_prag -- Add an Unfolding for an INLINE (but not for NOINLINE) -- And eta-expand the RHS; see Note [Eta-expanding INLINE things] - = (gbl_id `setIdUnfolding` mkInlineRule needSaturated rhs arity, + = (gbl_id `setIdUnfolding` mkInlineRule rhs (Just (dict_arity + arity)), + -- NB: The arity in the InlineRule takes account of the dictionaries etaExpand arity rhs) + | otherwise - = (gbl_id, rhs) + = (gbl_id `setIdUnfolding` mkInlineRule rhs Nothing, rhs) + where + inline_prag = idInlinePragma gbl_id + +dictArity :: [Var] -> Arity +-- Don't count coercion variables in arity +dictArity dicts = count isId dicts + ------------------------ -type AbsBindEnv = VarEnv ([TyVar], Id, Id, [LSpecPrag]) +type AbsBindEnv = VarEnv ([TyVar], Id, Id, TcSpecPrags) -- Maps the "lcl_id" for an AbsBind to -- its "gbl_id" and associated pragmas, if any -mkABEnv :: [([TyVar], Id, Id, [LSpecPrag])] -> AbsBindEnv +mkABEnv :: [([TyVar], Id, Id, TcSpecPrags)] -> AbsBindEnv -- Takes the exports of a AbsBinds, and returns a mapping -- lcl_id -> (tyvars, gbl_id, lcl_id, prags) mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports] - -mkArityEnv :: LHsBinds Id -> IdEnv Arity - -- Maps a local to the arity of its definition -mkArityEnv binds = foldrBag (plusVarEnv . lhsBindArity) emptyVarEnv binds - -lhsBindArity :: LHsBind Id -> IdEnv Arity -lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) - = unitVarEnv (unLoc id) (matchGroupArity ms) -lhsBindArity (L _ (AbsBinds { abs_exports = exports - , abs_dicts = dicts - , abs_binds = binds })) - = mkVarEnv [ (gbl, lookupArity ar_env lcl + n_val_dicts) - | (_, gbl, lcl, _) <- exports] - where -- See Note [Nested arities] - ar_env = mkArityEnv binds - n_val_dicts = dictArity dicts - -lhsBindArity _ = emptyVarEnv -- PatBind/VarBind - -dictArity :: [Var] -> Arity --- Don't count coercion variables in arity -dictArity dicts = count isId dicts - -lookupArity :: IdEnv Arity -> Id -> Arity -lookupArity ar_env id = lookupVarEnv ar_env id `orElse` 0 \end{code} Note [Eta-expanding INLINE things] @@ -435,17 +420,19 @@ Note that \begin{code} ------------------------ dsSpecs :: [TyVar] -> [DictId] -> [TyVar] - -> Id -> Id -> Arity -- Global, local, arity of local - -> CoreBind -> [LSpecPrag] + -> Id -> Id -- Global, local + -> CoreBind -> TcSpecPrags -> DsM ( [(Id,CoreExpr)] -- Binding for specialised Ids , [CoreRule] ) -- Rules for the Global Ids -- See Note [Implementing SPECIALISE pragmas] -dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags - = do { pairs <- mapMaybeM spec_one prags - ; let (spec_binds_s, rules) = unzip pairs - ; return (concat spec_binds_s, rules) } +dsSpecs all_tvs dicts tvs poly_id mono_id mono_bind prags + = case prags of + IsDefaultMethod -> return ([], []) + SpecPrags sps -> do { pairs <- mapMaybeM spec_one sps + ; let (spec_binds_s, rules) = unzip pairs + ; return (concat spec_binds_s, rules) } where - spec_one :: LSpecPrag -> DsM (Maybe ([(Id,CoreExpr)], CoreRule)) + spec_one :: Located TcSpecPrag -> DsM (Maybe ([(Id,CoreExpr)], CoreRule)) spec_one (L loc (SpecPrag spec_co spec_inl)) = putSrcSpanDs loc $ do { let poly_name = idName poly_id @@ -475,8 +462,6 @@ dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags -- Get the INLINE pragma from SPECIALISE declaration, or, -- failing that, from the original Id - spec_id_arity = inl_arity + count isDictId bndrs - extra_dict_bndrs = [ localiseId d -- See Note [Constant rule dicts] | d <- varSetElems (exprFreeVars ds_spec_expr) , isDictId d] @@ -488,7 +473,7 @@ dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags (mkVarApps (Var spec_id) bndrs) spec_rhs = wrap_fn (mkLams (tvs ++ dicts) f_body) - spec_pair = makeCorePair spec_id spec_id_arity spec_rhs + spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs ; return (Just (spec_pair : unf_pairs, rule)) } } } } diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index fa57d41..034949f 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -207,7 +207,7 @@ dsFCall fn_id fcall = do work_app = mkApps (mkVarApps (Var work_id) tvs) val_args wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers wrap_rhs = mkLams (tvs ++ args) wrapper_body - fn_id_w_inl = fn_id `setIdUnfolding` mkInlineRule needSaturated wrap_rhs (length args) + fn_id_w_inl = fn_id `setIdUnfolding` mkInlineRule wrap_rhs (Just (length args)) return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty) \end{code} diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 91d1b90..01af78b 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -399,7 +399,8 @@ cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlinePragma cvtInlineSpec Nothing = defaultInlinePragma cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) - = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo, inl_inline = inline } + = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo + , inl_inline = inline, inl_sat = Nothing } where matchinfo = cvtRuleMatchInfo conlike opt_activation' = cvtActivation opt_activation diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index ba3dbd6..f364883 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -143,7 +143,7 @@ data HsBindLR idL idR -- AbsBinds only gets used when idL = idR after renaming, -- but these need to be idL's for the collect... code in HsUtil to have -- the right type - abs_exports :: [([TyVar], idL, idL, [LSpecPrag])], -- (tvs, poly_id, mono_id, prags) + abs_exports :: [([TyVar], idL, idL, TcSpecPrags)], -- (tvs, poly_id, mono_id, prags) abs_binds :: LHsBinds idL -- The dictionary bindings and typechecked user bindings -- mixed up together; you can tell the dict bindings because -- they are all VarBinds @@ -292,7 +292,7 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars, where ppr_exp (tvs, gbl, lcl, prags) = vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl, - nest 2 (vcat (map (pprPrag gbl) prags))] + nest 2 (pprTcSpecPrags gbl prags)] \end{code} @@ -471,15 +471,28 @@ data Sig name -- Signatures and pragmas type LFixitySig name = Located (FixitySig name) data FixitySig name = FixitySig (Located name) Fixity --- A Prag conveys pragmas from the type checker to the desugarer -type LSpecPrag = Located SpecPrag -data SpecPrag +-- TsSpecPrags conveys pragmas from the type checker to the desugarer +data TcSpecPrags + = IsDefaultMethod -- Super-specialised: a default method should + -- be macro-expanded at every call site + | SpecPrags [Located TcSpecPrag] + +data TcSpecPrag = SpecPrag HsWrapper -- An wrapper, that specialises the polymorphic function InlinePragma -- Inlining spec for the specialised function -instance Outputable SpecPrag where - ppr (SpecPrag _ p) = ptext (sLit "SpecPrag") <+> ppr p +noSpecPrags :: TcSpecPrags +noSpecPrags = SpecPrags [] + +hasSpecPrags :: TcSpecPrags -> Bool +hasSpecPrags (SpecPrags ps) = not (null ps) +hasSpecPrags IsDefaultMethod = False + +isDefaultMethod :: TcSpecPrags -> Bool +isDefaultMethod IsDefaultMethod = True +isDefaultMethod (SpecPrags {}) = False + \end{code} \begin{code} @@ -600,7 +613,14 @@ pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var p pp_inl | isDefaultInlinePragma inl = empty | otherwise = ppr inl -pprPrag :: Outputable id => id -> LSpecPrag -> SDoc -pprPrag var (L _ (SpecPrag _expr inl)) = pprSpec var (ptext (sLit "")) inl +pprTcSpecPrags :: Outputable id => id -> TcSpecPrags -> SDoc +pprTcSpecPrags _ IsDefaultMethod = ptext (sLit "") +pprTcSpecPrags gbl (SpecPrags ps) = vcat (map (pprSpecPrag gbl) ps) + +pprSpecPrag :: Outputable id => id -> Located TcSpecPrag -> SDoc +pprSpecPrag var (L _ (SpecPrag _expr inl)) = pprSpec var (ptext (sLit "")) inl + +instance Outputable TcSpecPrag where + ppr (SpecPrag _ p) = ptext (sLit "SpecPrag") <+> ppr p \end{code} diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index beb39c0..2931ffa 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -600,16 +600,18 @@ instance Binary RuleMatchInfo where else return FunLike instance Binary InlinePragma where - put_ bh (InlinePragma a b c) = do + put_ bh (InlinePragma a b c d) = do put_ bh a put_ bh b put_ bh c + put_ bh d get bh = do a <- get bh b <- get bh c <- get bh - return (InlinePragma a b c) + d <- get bh + return (InlinePragma a b c d) instance Binary StrictnessMark where put_ bh MarkedStrict = putByte bh 0 @@ -1188,11 +1190,12 @@ instance Binary IfaceUnfolding where put_ bh (IfCoreUnfold e) = do putByte bh 0 put_ bh e - put_ bh (IfInlineRule a b e) = do + put_ bh (IfInlineRule a b c d) = do putByte bh 1 put_ bh a put_ bh b - put_ bh e + put_ bh c + put_ bh d put_ bh (IfWrapper a n) = do putByte bh 2 put_ bh a @@ -1200,6 +1203,9 @@ instance Binary IfaceUnfolding where put_ bh (IfDFunUnfold as) = do putByte bh 3 put_ bh as + put_ bh (IfCompulsory e) = do + putByte bh 4 + put_ bh e get bh = do h <- getByte bh case h of @@ -1207,13 +1213,16 @@ instance Binary IfaceUnfolding where return (IfCoreUnfold e) 1 -> do a <- get bh b <- get bh - e <- get bh - return (IfInlineRule a b e) + c <- get bh + d <- get bh + return (IfInlineRule a b c d) 2 -> do a <- get bh n <- get bh return (IfWrapper a n) - _ -> do as <- get bh + 3 -> do as <- get bh return (IfDFunUnfold as) + _ -> do e <- get bh + return (IfCompulsory e) instance Binary IfaceNote where put_ bh (IfaceSCC aa) = do diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 9485dc9..1db7822 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -211,11 +211,16 @@ data IfaceInfoItem data IfaceUnfolding = IfCoreUnfold IfaceExpr + | IfCompulsory IfaceExpr -- Only used for default methods, in fact + | IfInlineRule Arity Bool -- OK to inline even if *un*-saturated + Bool -- OK to inline even if context is boring IfaceExpr + | IfWrapper Arity Name -- NB: we need a Name (not just OccName) because the worker -- can simplify to a function in another module. + | IfDFunUnfold [IfaceExpr] -------------------------------- @@ -676,10 +681,11 @@ instance Outputable IfaceInfoItem where ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs") instance Outputable IfaceUnfolding where + ppr (IfCompulsory e) = ptext (sLit "") <+> parens (ppr e) ppr (IfCoreUnfold e) = parens (ppr e) - ppr (IfInlineRule a b e) = ptext (sLit "InlineRule:") - <+> parens (ptext (sLit "arity") <+> int a <+> ppr b) - <+> parens (ppr e) + ppr (IfInlineRule a uok bok e) = ptext (sLit "InlineRule") + <+> ppr (a,uok,bok) + <+> parens (ppr e) ppr (IfWrapper a wkr) = ptext (sLit "Worker:") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a) ppr (IfDFunUnfold ns) = ptext (sLit "DFun:") <+> brackets (pprWithCommas (pprIfaceExpr parens) ns) @@ -799,10 +805,11 @@ freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u freeNamesItem _ = emptyNameSet freeNamesIfUnfold :: IfaceUnfolding -> NameSet -freeNamesIfUnfold (IfCoreUnfold e) = freeNamesIfExpr e -freeNamesIfUnfold (IfInlineRule _ _ e) = freeNamesIfExpr e -freeNamesIfUnfold (IfWrapper _ v) = unitNameSet v -freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr vs +freeNamesIfUnfold (IfCoreUnfold e) = freeNamesIfExpr e +freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e +freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e +freeNamesIfUnfold (IfWrapper _ v) = unitNameSet v +freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr vs freeNamesIfExpr :: IfaceExpr -> NameSet freeNamesIfExpr (IfaceExt v) = unitNameSet v diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 1c34edc..702a744 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1503,20 +1503,21 @@ toIfaceIdInfo id_info -------------------------- toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem -toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity - , uf_src = src, uf_guidance = guidance }) - = case src of - InlineWrapper w -> Just (HsUnfold lb (IfWrapper arity (idName w))) - InlineRule {} -> Just (HsUnfold lb (IfInlineRule arity sat (toIfaceExpr rhs))) - _other -> Just (HsUnfold lb (IfCoreUnfold (toIfaceExpr rhs))) +toIfUnfolding lb unf@(CoreUnfolding { uf_tmpl = rhs, uf_arity = arity + , uf_src = src, uf_guidance = guidance }) + = Just $ HsUnfold lb $ + case src of + InlineRule {} + -> case guidance of + UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok (toIfaceExpr rhs) + _other -> pprPanic "toIfUnfolding" (ppr unf) + InlineWrapper w -> IfWrapper arity (idName w) + InlineCompulsory -> IfCompulsory (toIfaceExpr rhs) + InlineRhs -> IfCoreUnfold (toIfaceExpr rhs) -- Yes, even if guidance is UnfNever, expose the unfolding -- If we didn't want to expose the unfolding, TidyPgm would -- have stuck in NoUnfolding. For supercompilation we want -- to see that unfolding! - where - sat = case guidance of - UnfWhen unsat_ok _ -> unsat_ok - _other -> needSaturated toIfUnfolding lb (DFunUnfolding _con ops) = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops))) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index c9c33db..7d0d02e 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -1015,11 +1015,19 @@ tcUnfolding name _ info (IfCoreUnfold if_expr) Just sig -> isBottomingSig sig Nothing -> False -tcUnfolding name _ _ (IfInlineRule arity unsat_ok if_expr) +tcUnfolding name _ _ (IfCompulsory if_expr) = do { mb_expr <- tcPragExpr name if_expr ; return (case mb_expr of Nothing -> NoUnfolding - Just expr -> mkInlineRule unsat_ok expr arity) } + Just expr -> mkCompulsoryUnfolding expr) } + +tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr) + = do { mb_expr <- tcPragExpr name if_expr + ; return (case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkCoreUnfolding True InlineRule expr arity + (UnfWhen unsat_ok boring_ok)) + } tcUnfolding name ty info (IfWrapper arity wkr) = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr) diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 300d886..2700c6f 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -977,6 +977,7 @@ mkInlinePragma :: Maybe Activation -> RuleMatchInfo -> Bool -> InlinePragma -- The Maybe is because the user can omit the activation spec (and usually does) mkInlinePragma mb_act match_info inl = InlinePragma { inl_inline = inl + , inl_sat = Nothing , inl_act = act , inl_rule = match_info } where diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 2001a17..a5a581b 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -1982,7 +1982,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') DataAlt dc -> setIdUnfolding case_bndr unf where -- See Note [Case binders and join points] - unf = mkInlineRule needSaturated rhs 0 + unf = mkInlineRule rhs Nothing rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty) ++ varsToCoreExprs bndrs') diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 4342534..5c29ffb 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -915,10 +915,15 @@ specDefn subst body_uds fn rhs -- Add an InlineRule if the parent has one -- See Note [Inline specialisations] - final_spec_f | Just sat <- fn_has_inline_rule - = spec_f_w_arity `setIdUnfolding` mkInlineRule sat spec_rhs spec_arity - | otherwise - = spec_f_w_arity + final_spec_f + | Just sat <- fn_has_inline_rule + = let + mb_spec_arity = if sat then Just spec_arity else Nothing + in + spec_f_w_arity `setIdUnfolding` mkInlineRule spec_rhs mb_spec_arity + | otherwise + = spec_f_w_arity + ; return (Just ((final_spec_f, spec_rhs), final_uds, spec_env_rule)) } } where my_zipEqual xs ys zs diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs index 2547978..b0759b9 100644 --- a/compiler/stranal/WorkWrap.lhs +++ b/compiler/stranal/WorkWrap.lhs @@ -274,8 +274,8 @@ checkSize fn_id rhs thing_inside | otherwise = thing_inside where - unfolding = idUnfolding fn_id - inline_rule = mkInlineRule unSaturatedOk rhs (unfoldingArity unfolding) + unfolding = idUnfolding fn_id + inline_rule = mkInlineRule rhs Nothing --------------------- splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Expr Var @@ -314,15 +314,16 @@ splitFun fn_id fn_info wrap_dmds res_info rhs wrap_rhs = wrap_fn work_id wrap_prag = InlinePragma { inl_inline = True + , inl_sat = Nothing , inl_act = ActiveAfter 0 , inl_rule = rule_match_info } + -- See Note [Wrapper activation] + -- The RuleMatchInfo is (and must be) unaffected + -- The inl_inline is bound to be False, else we would not be + -- making a wrapper wrap_id = fn_id `setIdUnfolding` mkWwInlineRule work_id wrap_rhs arity `setInlinePragma` wrap_prag - -- See Note [Wrapper activation] - -- The RuleMatchInfo is (and must be) unaffected - -- The inl_inline is bound to be False, else we would not be - -- making a wrapper `setIdOccInfo` NoOccInfo -- Zap any loop-breaker-ness, to avoid bleating from Lint -- about a loop breaker with an INLINE rule diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index f21bbe6..2871f3b 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -149,7 +149,7 @@ tcValBinds _ (ValBindsIn binds _) _ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside = do { -- Typecheck the signature - ; let { prag_fn = mkPragFun sigs + ; let { prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds) ; ty_sigs = filter isTypeLSig sigs ; sig_fn = mkTcSigFun ty_sigs } @@ -336,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 @@ -372,7 +376,7 @@ mkExport :: TopLevelFlag -> RecFlag -- a tuple, so INLINE pragmas won't work -> TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo - -> TcM ([TyVar], Id, Id, [LSpecPrag]) + -> TcM ([TyVar], Id, Id, TcSpecPrags) -- mkExport generates exports with -- zonked type variables, -- zonked poly_ids @@ -395,7 +399,7 @@ mkExport top_lvl rec_group multi_bind prag_fn inferred_tvs dict_tys poly_id (prag_fn poly_name) -- tcPrags requires a zonked poly_id - ; return (tvs, poly_id', mono_id, spec_prags) } + ; return (tvs, poly_id', mono_id, SpecPrags spec_prags) } where poly_ty = mkForAllTys inferred_tvs (mkFunTys dict_tys (idType mono_id)) @@ -410,22 +414,41 @@ mkExport top_lvl rec_group multi_bind prag_fn inferred_tvs dict_tys ------------------------ 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 +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, [LSpecPrag]) + -> TcM (Id, [Located TcSpecPrag]) -- Add INLINE and SPECLIASE pragmas --- INLINE prags are added to the Id directly --- SPECIALISE prags are passed to the desugarer via [LSpecPrag] +-- 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 @@ -491,7 +514,7 @@ warnPrags id bad_sigs herald ppr_sigs sigs = vcat (map (ppr . getLoc) sigs) -------------- -tcSpecPrag :: TcId -> Sig Name -> TcM SpecPrag +tcSpecPrag :: TcId -> Sig Name -> TcM TcSpecPrag tcSpecPrag poly_id prag@(SpecSig _ hs_ty inl) = addErrCtxt (spec_ctxt prag) $ do { let name = idName poly_id diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 23ee423..2d113b7 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -179,7 +179,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, ; let (tyvars, _, _, op_items) = classBigSig clas rigid_info = ClsSkol clas - prag_fn = mkPragFun sigs + prag_fn = mkPragFun sigs default_binds sig_fn = mkTcSigFun sigs clas_tyvars = tcSkolSigTyVars rigid_info tyvars pred = mkClassPred clas (mkTyVarTys clas_tyvars) @@ -234,16 +234,20 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn sel_id ; (dm_id_w_inline, spec_prags) <- tcPrags NonRecursive False True dm_id (prag_fn sel_name) + ; warnTc (not (null spec_prags)) + (ptext (sLit "Ignoring SPECIALISE pragmas on default method") + <+> quotes (ppr sel_name)) + ; tcInstanceMethodBody (instLoc this_dict) tyvars [this_dict] ([], emptyBag) dm_id_w_inline local_dm_id - dm_sig_fn spec_prags meth_bind } + dm_sig_fn IsDefaultMethod meth_bind } --------------- tcInstanceMethodBody :: InstLoc -> [TcTyVar] -> [Inst] -> ([Inst], LHsBinds Id) -> Id -> Id - -> TcSigFun -> [LSpecPrag] -> LHsBind Name + -> TcSigFun -> TcSpecPrags -> LHsBind Name -> TcM (Id, LHsBind Id) tcInstanceMethodBody inst_loc tyvars dfun_dicts (this_dict, this_bind) meth_id local_meth_id diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index ee6de33..e46ab45 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -363,8 +363,12 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts, zonkExport env (tyvars, global, local, prags) -- The tyvars are already zonked = zonkIdBndr env global `thenM` \ new_global -> - mapM zonk_prag prags `thenM` \ new_prags -> + zonk_prags prags `thenM` \ new_prags -> returnM (tyvars, new_global, zonkIdOcc env local, new_prags) + + zonk_prags IsDefaultMethod = return IsDefaultMethod + zonk_prags (SpecPrags ps) = do { ps' <- mapM zonk_prag ps; return (SpecPrags ps') } + zonk_prag (L loc (SpecPrag co_fn inl)) = do { (_, co_fn') <- zonkCoFn env co_fn ; return (L loc (SpecPrag co_fn' inl)) } diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 1af025e..c4c5d58 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -33,8 +33,6 @@ import DataCon import Class import Var import CoreUnfold ( mkDFunUnfolding ) --- import CoreUtils ( mkPiTypes ) -import PrelNames ( inlineIdName ) import Id import MkId import Name @@ -667,7 +665,7 @@ tc_inst_decl2 dfun_id (NewTypeDerived coi) ; return (unitBag $ noLoc $ AbsBinds inst_tvs' (map instToVar dfun_dicts) - [(inst_tvs', dfun_id, instToId this_dict, [])] + [(inst_tvs', dfun_id, instToId this_dict, noSpecPrags)] (dict_bind `consBag` sc_binds)) } where ----------------------- @@ -753,7 +751,7 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv) ; spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) spec_inst_sigs -- Typecheck the methods - ; let prag_fn = mkPragFun uprags + ; let prag_fn = mkPragFun uprags monobinds tc_meth = tcInstanceMethod loc standalone_deriv clas inst_tyvars' dfun_dicts inst_tys' @@ -801,7 +799,7 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv) main_bind = AbsBinds inst_tyvars' dfun_lam_vars - [(inst_tyvars', dfun_id_w_fun, this_dict_id, spec_inst_prags)] + [(inst_tyvars', dfun_id_w_fun, this_dict_id, SpecPrags spec_inst_prags)] (unitBag dict_bind) ; showLIE (text "instance") @@ -891,7 +889,7 @@ tcSuperClass inst_loc tyvars dicts (this_dict, this_bind) sc_id = instToVar sc_dict sc_op_bind = AbsBinds tyvars (map instToVar dicts) - [(tyvars, sc_op_id, sc_id, [])] + [(tyvars, sc_op_id, sc_id, noSpecPrags)] (this_bind `unionBags` sc_binds) ; return (sc_op_id, noLoc sc_op_bind) } @@ -948,7 +946,7 @@ SpecPrag which, as it turns out, can be used unchanged for each method. The "it turns out" bit is delicate, but it works fine! \begin{code} -tcSpecInst :: Id -> Sig Name -> TcM SpecPrag +tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag tcSpecInst dfun_id prag@(SpecInstSig hs_ty) = addErrCtxt (spec_ctxt prag) $ do { let name = idName dfun_id @@ -981,7 +979,7 @@ tcInstanceMethod :: SrcSpan -> Bool -> Class -> [TcTyVar] -> [Inst] -> [TcType] -> (Inst, LHsBinds Id) -- "This" and its binding -> TcPragFun -- Local prags - -> [LSpecPrag] -- Arising from 'SPECLALISE instance' + -> [Located TcSpecPrag] -- Arising from 'SPECLALISE instance' -> LHsBinds Name -> (Id, DefMeth) -> TcM (Id, LHsBind Id) @@ -1006,13 +1004,13 @@ tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts inst_tys tc_body rn_bind = add_meth_ctxt rn_bind $ do { (meth_id1, spec_prags) <- tcPrags NonRecursive False True - meth_id (prag_fn sel_name) + meth_id (prag_fn sel_name) ; tcInstanceMethodBody (instLoc this_dict) tyvars dfun_dicts ([this_dict], this_dict_bind) meth_id1 local_meth_id meth_sig_fn - (spec_inst_prags ++ spec_prags) + (SpecPrags (spec_inst_prags ++ spec_prags)) rn_bind } -------------- @@ -1040,14 +1038,9 @@ tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts inst_tys dm_name <- lookupGlobalOccRn (mkDefMethRdrName sel_name) -- Might not be imported, but will be an OrigName ; dm_id <- tcLookupId dm_name - ; inline_id <- tcLookupId inlineIdName ; let dm_inline_prag = idInlinePragma dm_id - dm_app = HsWrap (WpApp (instToId this_dict) <.> mkWpTyApps inst_tys) $ - HsVar dm_id - rhs | isInlinePragma dm_inline_prag -- See Note [INLINE and default methods] - = HsApp (L loc (HsWrap (WpTyApp local_meth_ty) (HsVar inline_id))) - (L loc dm_app) - | otherwise = dm_app + rhs = HsWrap (WpApp (instToId this_dict) <.> mkWpTyApps inst_tys) $ + HsVar dm_id meth_bind = L loc $ VarBind { var_id = local_meth_id , var_rhs = L loc rhs @@ -1057,8 +1050,8 @@ tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts inst_tys -- method to this version. Note [INLINE and default methods] bind = AbsBinds { abs_tvs = tyvars, abs_dicts = dfun_lam_vars - , abs_exports = [( tyvars, meth_id1 - , local_meth_id, spec_inst_prags)] + , abs_exports = [( tyvars, meth_id1, local_meth_id + , SpecPrags spec_inst_prags)] , abs_binds = this_dict_bind `unionBags` unitBag meth_bind } -- Default methods in an instance declaration can't have their own -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but @@ -1143,7 +1136,8 @@ From the class decl we get $dmfoo :: forall v x. Baz v x => x -> x $dmfoo y = -Notice that the type is ambiguous. That's fine, though. The instance decl generates +Notice that the type is ambiguous. That's fine, though. The instance +decl generates $dBazIntInt = MkBaz fooIntInt fooIntInt = $dmfoo Int Int $dBazIntInt @@ -1155,8 +1149,9 @@ less work to generate the translated version! Note [INLINE and default methods] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We *copy* any INLINE pragma from the default method to the instance. -Example: +Default methods need special case. They are supposed to behave rather like +macros. For exmample + class Foo a where op1, op2 :: Bool -> a -> a @@ -1164,31 +1159,57 @@ Example: op1 b x = op2 (not b) x instance Foo Int where + -- op1 via default method op2 b x = + +The instance declaration should behave + + just as if 'op1' had been defined with the + code, and INLINE pragma, from its original + definition. + +That is, just as if you'd written + + instance Foo Int where + op2 b x = + + {-# INLINE op1 #-} + op1 b x = op2 (not b) x + +So for the above example we generate: -Then we generate: {-# INLINE $dmop1 #-} + -- $dmop1 has an InlineCompulsory unfolding $dmop1 d b x = op2 d (not b) x $fFooInt = MkD $cop1 $cop2 {-# INLINE $cop1 #-} - $cop1 = inline $dmop1 $fFooInt + $cop1 = $dmop1 $fFooInt $cop2 = -Note carefully: - a) We copy $dmop1's inline pragma to $cop1. Otherwise - we'll just inline the former in the latter and stop, which - isn't what the user expected - - b) We use the magic 'inline' Id to ensure that $dmop1 really is - inlined in $cop1, even though - (i) the latter itself has an INLINE pragma - (ii) $dmop1 is not saturated - That is important to allow the mutual recursion between $fooInt and - $cop1 to be broken +Note carefullly: + +* We *copy* any INLINE pragma from the default method $dmop1 to the + instance $cop1. Otherwise we'll just inline the former in the + latter and stop, which isn't what the user expected + +* Regardless of its pragma, we give the default method an + unfolding with an InlineCompulsory source. That means + that it'll be inlined at every use site, notably in + each instance declaration, such as $cop1. This inlining + must happen even though + a) $dmop1 is not saturated in $cop1 + b) $cop1 itself has an INLINE pragma + + It's vital that $dmop1 *is* inlined in this way, to allow the mutual + recursion between $fooInt and $cop1 to be broken + +* To communicate the need for an InlineCompulsory to the desugarer + (which makes the Unfoldings), we use the IsDefaultMethod constructor + in TcSpecPrags. %************************************************************************ diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index f31ecd8..83fd512 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -789,7 +789,7 @@ vectDataConWorkers orig_tc vect_tc arr_tc raw_worker <- cloneId mkVectOcc orig_worker (exprType body) let vect_worker = raw_worker `setIdUnfolding` - mkInlineRule needSaturated body arity + mkInlineRule body (Just arity) defGlobalVar orig_worker vect_worker return (vect_worker, body) where @@ -830,7 +830,7 @@ buildPADict vect_tc prepr_tc arr_tc repr let body = mkLams (tvs ++ args) expr raw_var <- newExportedVar (method_name name) (exprType body) let var = raw_var - `setIdUnfolding` mkInlineRule needSaturated body (length args) + `setIdUnfolding` mkInlineRule body (Just (length args)) `setInlinePragma` alwaysInlinePragma hoistBinding var body return var diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs index 8dccd61..c62c405 100644 --- a/compiler/vectorise/VectUtils.hs +++ b/compiler/vectorise/VectUtils.hs @@ -38,7 +38,7 @@ import Var import MkId ( unwrapFamInstScrut ) import Id ( setIdUnfolding ) import TysWiredIn -import BasicTypes ( Boxity(..) ) +import BasicTypes ( Boxity(..), Arity ) import Literal ( Literal, mkMachInt ) import Outputable @@ -348,7 +348,7 @@ polyVApply expr tys return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr -data Inline = Inline Int -- arity +data Inline = Inline Arity | DontInline addInlineArity :: Inline -> Int -> Inline @@ -371,7 +371,7 @@ hoistExpr fs expr inl where mk_inline var = case inl of Inline arity -> var `setIdUnfolding` - mkInlineRule needSaturated expr arity + mkInlineRule expr (Just arity) DontInline -> var hoistVExpr :: VExpr -> Inline -> VM VVar diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index cc91e9f..c53c638 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -106,7 +106,7 @@ vectTopBinder var inline expr return var' where unfolding = case inline of - Inline arity -> mkInlineRule needSaturated expr arity + Inline arity -> mkInlineRule expr (Just arity) DontInline -> noUnfolding vectTopRhs :: Var -> CoreExpr -> VM (Inline, CoreExpr)