From: simonpj@microsoft.com Date: Wed, 15 Sep 2010 12:44:42 +0000 (+0000) Subject: Implement INLINABLE pragma X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=a51fe79ebcdcb8285573a18f12cade2101533419 Implement INLINABLE pragma Implements Trac #4299. Documentation to come. --- diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 8cd5c35..f125714 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -62,8 +62,10 @@ module BasicTypes( CompilerPhase, Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive, RuleMatchInfo(..), isConLike, isFunLike, - InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma, - isDefaultInlinePragma, isInlinePragma, inlinePragmaSat, + InlineSpec(..), + InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, + neverInlinePragma, dfunInlinePragma, + isDefaultInlinePragma, isInlinePragma, inlinePragmaSpec, inlinePragmaSat, inlinePragmaActivation, inlinePragmaRuleMatchInfo, setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, @@ -645,12 +647,12 @@ data Activation = NeverActive data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] | FunLike - deriving( Eq, Data, Typeable ) + deriving( Eq, Data, Typeable, Show ) + -- Show needed for Lexer.x data InlinePragma -- Note [InlinePragma] = InlinePragma - { inl_inline :: Bool -- True <=> INLINE, - -- False <=> no pragma at all, or NOINLINE + { inl_inline :: InlineSpec , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n -- explicit (non-type, non-dictionary) args @@ -663,6 +665,14 @@ data InlinePragma -- Note [InlinePragma] , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? } deriving( Eq, Data, Typeable ) + +data InlineSpec -- What the user's INLINE pragama looked like + = Inline + | Inlinable + | NoInline + | EmptyInlineSpec + deriving( Eq, Data, Typeable, Show ) + -- Show needed for Lexer.x \end{code} Note [InlinePragma] @@ -725,16 +735,24 @@ isFunLike :: RuleMatchInfo -> Bool isFunLike FunLike = True isFunLike _ = False +isInlineSpec :: InlineSpec -> Bool +isInlineSpec Inline = True +isInlineSpec Inlinable = True +isInlineSpec _ = False + defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma :: InlinePragma defaultInlinePragma = InlinePragma { inl_act = AlwaysActive , inl_rule = FunLike - , inl_inline = False + , inl_inline = EmptyInlineSpec , inl_sat = Nothing } -alwaysInlinePragma = defaultInlinePragma { inl_inline = True } +alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline } neverInlinePragma = defaultInlinePragma { inl_act = NeverActive } +inlinePragmaSpec :: InlinePragma -> InlineSpec +inlinePragmaSpec = inl_inline + -- A DFun has an always-active inline activation so that -- exprIsConApp_maybe can "see" its unfolding -- (However, its actual Unfolding is a DFunUnfolding, which is @@ -746,10 +764,10 @@ isDefaultInlinePragma :: InlinePragma -> Bool isDefaultInlinePragma (InlinePragma { inl_act = activation , inl_rule = match_info , inl_inline = inline }) - = not inline && isAlwaysActive activation && isFunLike match_info + = isInlineSpec inline && isAlwaysActive activation && isFunLike match_info isInlinePragma :: InlinePragma -> Bool -isInlinePragma prag = inl_inline prag +isInlinePragma prag = isInlineSpec (inl_inline prag) inlinePragmaSat :: InlinePragma -> Maybe Arity inlinePragmaSat = inl_sat @@ -776,16 +794,20 @@ instance Outputable RuleMatchInfo where ppr ConLike = ptext (sLit "CONLIKE") ppr FunLike = ptext (sLit "FUNLIKE") +instance Outputable InlineSpec where + ppr Inline = ptext (sLit "INLINE") + ppr NoInline = ptext (sLit "NOINLINE") + ppr Inlinable = ptext (sLit "INLINABLE") + ppr EmptyInlineSpec = empty + instance Outputable InlinePragma where ppr (InlinePragma { inl_inline = inline, inl_act = activation , inl_rule = info, inl_sat = mb_arity }) - = pp_inl_act (inline, activation) <+> pp_sat <+> pp_info + = ppr inline <> pp_act inline activation <+> pp_sat <+> pp_info where - pp_inl_act (False, AlwaysActive) = empty -- defaultInlinePragma - pp_inl_act (False, NeverActive) = ptext (sLit "NOINLINE") - pp_inl_act (False, act) = ptext (sLit "NOINLINE") <> ppr act - pp_inl_act (True, AlwaysActive) = ptext (sLit "INLINE") - pp_inl_act (True, act) = ptext (sLit "INLINE") <> ppr act + pp_act Inline AlwaysActive = empty + pp_act NoInline NeverActive = empty + pp_act _ act = ppr act pp_sat | Just ar <- mb_arity = parens (ptext (sLit "sat-args=") <> int ar) | otherwise = empty diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 774c919..4c41d28 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -317,7 +317,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 wrap_rhs (Just (length dict_args + length id_args)) + wrap_unf = mkInlineUnfolding (Just (length dict_args + length id_args)) wrap_rhs wrap_rhs = mkLams wrap_tvs $ mkLams eq_args $ mkLams dict_args $ mkLams id_args $ diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index e5cbfc4..90d7619 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -422,7 +422,7 @@ idUnfoldingVars :: Id -> VarSet idUnfoldingVars id = case realIdUnfolding id of CoreUnfolding { uf_tmpl = rhs, uf_src = src } - | isInlineRuleSource src + | isStableSource src -> exprFreeVars rhs DFunUnfolding _ _ args -> exprsFreeVars args _ -> emptyVarSet diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index 4f92b1a..7ca5a67 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -555,9 +555,9 @@ substUnfolding subst (DFunUnfolding ar con args) substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) -- Retain an InlineRule! - | not (isInlineRuleSource src) -- Always zap a CoreUnfolding, to save substitution work + | not (isStableSource src) -- Zap an unstable unfolding, to save substitution work = NoUnfolding - | otherwise -- But keep an InlineRule! + | otherwise -- But keep a stable one! = seqExpr new_tmpl `seq` new_src `seq` unf { uf_tmpl = new_tmpl, uf_src = new_src } @@ -576,7 +576,7 @@ substUnfoldingSource (Subst in_scope ids _) (InlineWrapper wkr) _other -> -- WARN( True, text "Interesting! CoreSubst.substWorker1:" <+> ppr wkr -- <+> ifPprDebug (equals <+> ppr wkr_expr) ) -- Note [Worker inlining] - InlineRule -- It's not a wrapper any more, but still inline it! + InlineStable -- It's not a wrapper any more, but still inline it! | Just w1 <- lookupInScope in_scope wkr = InlineWrapper w1 | otherwise = -- WARN( True, text "Interesting! CoreSubst.substWorker2:" <+> ppr wkr ) @@ -584,7 +584,7 @@ substUnfoldingSource (Subst in_scope ids _) (InlineWrapper wkr) -- dropped as dead code, because we don't treat the UnfoldingSource -- as an "occurrence". -- Note [Worker inlining] - InlineRule + InlineStable substUnfoldingSource _ src = src diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index e09e4f2..05cc575 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -48,8 +48,9 @@ module CoreSyn ( maybeUnfoldingTemplate, otherCons, unfoldingArity, isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, - isInlineRule, isInlineRule_maybe, isClosedUnfolding, hasSomeUnfolding, - isStableUnfolding, canUnfold, neverUnfoldGuidance, isInlineRuleSource, + isStableUnfolding, isStableUnfolding_maybe, + isClosedUnfolding, hasSomeUnfolding, + canUnfold, neverUnfoldGuidance, isStableSource, -- * Strictness seqExpr, seqExprs, seqUnfolding, @@ -433,17 +434,20 @@ data Unfolding -- They are usually variables, but can be trivial expressions -- instead (e.g. a type application). - | CoreUnfolding { -- An unfolding for an Id with no pragma, or perhaps a NOINLINE pragma - -- (For NOINLINE, the phase, if any, is in the InlinePragInfo for this Id.) + | CoreUnfolding { -- An unfolding for an Id with no pragma, + -- or perhaps a NOINLINE pragma + -- (For NOINLINE, the phase, if any, is in the + -- InlinePragInfo for this Id.) uf_tmpl :: CoreExpr, -- Template; occurrence info is correct uf_src :: UnfoldingSource, -- Where the unfolding came from uf_is_top :: Bool, -- True <=> top level binding uf_arity :: Arity, -- Number of value arguments expected - uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard a `seq` on - -- this variable - uf_is_conlike :: Bool, -- True <=> application of constructor or CONLIKE function + uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard + -- a `seq` on this variable + uf_is_conlike :: Bool, -- True <=> applicn of constructor or CONLIKE function -- Cached version of exprIsConLike - uf_is_cheap :: Bool, -- True <=> doesn't waste (much) work to expand inside an inlining + uf_is_cheap :: Bool, -- True <=> doesn't waste (much) work to expand + -- inside an inlining -- Cached version of exprIsCheap uf_expandable :: Bool, -- True <=> can expand in RULE matching -- Cached version of exprIsExpandable @@ -467,13 +471,18 @@ data Unfolding ------------------------------------------------ data UnfoldingSource - = InlineCompulsory -- Something that *has* no binding, so you *must* inline it + = InlineRhs -- The current rhs of the function + -- Replace uf_tmpl each time around + + | InlineStable -- From an INLINE or INLINABLE pragma + -- Do not replace uf_tmpl; instead, keep it unchanged + -- See Note [InlineRules] + + | InlineCompulsory -- Something that *has* no binding, so you *must* inline it -- Only a few primop-like things have this property -- (see MkId.lhs, calls to mkCompulsoryUnfolding). -- Inline absolutely always, however boring the context. - | InlineRule -- From an {-# INLINE #-} pragma; See Note [InlineRules] - | InlineWrapper Id -- This unfolding is a the wrapper in a -- worker/wrapper split from the strictness analyser -- The Id is the worker-id @@ -481,10 +490,6 @@ data UnfoldingSource -- which don't need to contain the RHS; -- it can be derived from the strictness info - | InlineRhs -- The current rhs of the function - - -- For InlineRhs, the uf_tmpl is replaced each time around - -- For all the others we leave uf_tmpl alone -- | 'UnfoldingGuidance' says when unfolding should take place @@ -579,11 +584,12 @@ seqGuidance _ = () \end{code} \begin{code} -isInlineRuleSource :: UnfoldingSource -> Bool -isInlineRuleSource InlineCompulsory = True -isInlineRuleSource InlineRule = True -isInlineRuleSource (InlineWrapper {}) = True -isInlineRuleSource InlineRhs = False +isStableSource :: UnfoldingSource -> Bool +-- Keep the unfolding template +isStableSource InlineCompulsory = True +isStableSource InlineStable = True +isStableSource (InlineWrapper {}) = True +isStableSource InlineRhs = False -- | Retrieves the template of an unfolding: panics if none is known unfoldingTemplate :: Unfolding -> CoreExpr @@ -642,19 +648,15 @@ expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs expandUnfolding_maybe _ = Nothing -isInlineRule :: Unfolding -> Bool -isInlineRule (CoreUnfolding { uf_src = src }) = isInlineRuleSource src -isInlineRule _ = False - -isInlineRule_maybe :: Unfolding -> Maybe (UnfoldingSource, Bool) -isInlineRule_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide }) - | isInlineRuleSource src +isStableUnfolding_maybe :: Unfolding -> Maybe (UnfoldingSource, Bool) +isStableUnfolding_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide }) + | isStableSource src = Just (src, unsat_ok) where unsat_ok = case guide of UnfWhen unsat_ok _ -> unsat_ok _ -> needSaturated -isInlineRule_maybe _ = Nothing +isStableUnfolding_maybe _ = Nothing isCompulsoryUnfolding :: Unfolding -> Bool isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True @@ -663,7 +665,7 @@ isCompulsoryUnfolding _ = False isStableUnfolding :: Unfolding -> Bool -- True of unfoldings that should not be overwritten -- by a CoreUnfolding for the RHS of a let-binding -isStableUnfolding (CoreUnfolding { uf_src = src }) = isInlineRuleSource src +isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src isStableUnfolding (DFunUnfolding {}) = True isStableUnfolding _ = False diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 24d6330..18a0445 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -19,8 +19,9 @@ module CoreUnfold ( Unfolding, UnfoldingGuidance, -- Abstract types noUnfolding, mkImplicitUnfolding, - mkTopUnfolding, mkUnfolding, mkCoreUnfolding, - mkInlineRule, mkWwInlineRule, + mkUnfolding, mkCoreUnfolding, + mkTopUnfolding, mkSimpleUnfolding, + mkInlineUnfolding, mkInlinableUnfolding, mkWwInlineRule, mkCompulsoryUnfolding, mkDFunUnfolding, interestingArg, ArgSummary(..), @@ -44,7 +45,7 @@ import TcType ( tcSplitSigmaTy, tcSplitDFunHead ) import OccurAnal import CoreSubst hiding( substTy ) import CoreFVs ( exprFreeVars ) -import CoreArity ( manifestArity ) +import CoreArity ( manifestArity, exprBotStrictness_maybe ) import CoreUtils import Id import DataCon @@ -63,7 +64,7 @@ import Util import FastTypes import FastString import Outputable - +import Data.Maybe \end{code} @@ -75,8 +76,7 @@ import Outputable \begin{code} mkTopUnfolding :: Bool -> CoreExpr -> Unfolding -mkTopUnfolding is_bottoming expr - = mkUnfolding True {- Top level -} is_bottoming expr +mkTopUnfolding = mkUnfolding InlineRhs True {- Top level -} mkImplicitUnfolding :: CoreExpr -> Unfolding -- For implicit Ids, do a tiny bit of optimising first @@ -88,44 +88,8 @@ mkImplicitUnfolding expr = mkTopUnfolding False (simpleOptExpr expr) -- top-level flag to True. It gets set more accurately by the simplifier -- Simplify.simplUnfolding. -mkUnfolding :: Bool -> Bool -> CoreExpr -> Unfolding -mkUnfolding top_lvl is_bottoming expr - = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, - uf_src = InlineRhs, - uf_arity = arity, - uf_is_top = top_lvl, - uf_is_value = exprIsHNF expr, - uf_is_conlike = exprIsConLike expr, - uf_expandable = exprIsExpandable expr, - uf_is_cheap = is_cheap, - uf_guidance = guidance } - where - is_cheap = exprIsCheap expr - (arity, guidance) = calcUnfoldingGuidance is_cheap (top_lvl && is_bottoming) - opt_UF_CreationThreshold expr - -- Sometimes during simplification, there's a large let-bound thing - -- which has been substituted, and so is now dead; so 'expr' contains - -- two copies of the thing while the occurrence-analysed expression doesn't - -- Nevertheless, we *don't* occ-analyse before computing the size because the - -- size computation bales out after a while, whereas occurrence analysis does not. - -- - -- This can occasionally mean that the guidance is very pessimistic; - -- it gets fixed up next round. And it should be rare, because large - -- let-bound things that are dead are usually caught by preInlineUnconditionally - -mkCoreUnfolding :: Bool -> UnfoldingSource -> CoreExpr - -> Arity -> UnfoldingGuidance -> Unfolding --- Occurrence-analyses the expression before capturing it -mkCoreUnfolding top_lvl src expr arity guidance - = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, - uf_src = src, - uf_arity = arity, - uf_is_top = top_lvl, - uf_is_value = exprIsHNF expr, - uf_is_conlike = exprIsConLike expr, - uf_is_cheap = exprIsCheap expr, - uf_expandable = exprIsExpandable expr, - uf_guidance = guidance } +mkSimpleUnfolding :: CoreExpr -> Unfolding +mkSimpleUnfolding = mkUnfolding InlineRhs False False mkDFunUnfolding :: Type -> [CoreExpr] -> Unfolding mkDFunUnfolding dfun_ty ops @@ -150,10 +114,11 @@ mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolde expr 0 -- Arity of unfolding doesn't matter (UnfWhen unSaturatedOk boringCxtOk) -mkInlineRule :: CoreExpr -> Maybe Arity -> Unfolding -mkInlineRule expr mb_arity - = mkCoreUnfolding True InlineRule -- Note [Top-level flag on inline rules] - expr' arity +mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding +mkInlineUnfolding mb_arity expr + = mkCoreUnfolding True -- Note [Top-level flag on inline rules] + InlineStable + expr' arity (UnfWhen unsat_ok boring_ok) where expr' = simpleOptExpr expr @@ -167,8 +132,58 @@ mkInlineRule expr mb_arity (_, UnfWhen _ boring_ok) -> boring_ok _other -> boringCxtNotOk -- See Note [INLINE for small functions] + +mkInlinableUnfolding :: CoreExpr -> Unfolding +mkInlinableUnfolding expr + = mkUnfolding InlineStable True is_bot expr + where + is_bot = isJust (exprBotStrictness_maybe expr) \end{code} +Internal functions + +\begin{code} +mkCoreUnfolding :: Bool -> UnfoldingSource -> CoreExpr + -> Arity -> UnfoldingGuidance -> Unfolding +-- Occurrence-analyses the expression before capturing it +mkCoreUnfolding top_lvl src expr arity guidance + = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, + uf_src = src, + uf_arity = arity, + uf_is_top = top_lvl, + uf_is_value = exprIsHNF expr, + uf_is_conlike = exprIsConLike expr, + uf_is_cheap = exprIsCheap expr, + uf_expandable = exprIsExpandable expr, + uf_guidance = guidance } + +mkUnfolding :: UnfoldingSource -> Bool -> Bool -> CoreExpr -> Unfolding +-- Calculates unfolding guidance +-- Occurrence-analyses the expression before capturing it +mkUnfolding src top_lvl is_bottoming expr + = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, + uf_src = src, + uf_arity = arity, + uf_is_top = top_lvl, + uf_is_value = exprIsHNF expr, + uf_is_conlike = exprIsConLike expr, + uf_expandable = exprIsExpandable expr, + uf_is_cheap = is_cheap, + uf_guidance = guidance } + where + is_cheap = exprIsCheap expr + (arity, guidance) = calcUnfoldingGuidance is_cheap (top_lvl && is_bottoming) + opt_UF_CreationThreshold expr + -- Sometimes during simplification, there's a large let-bound thing + -- which has been substituted, and so is now dead; so 'expr' contains + -- two copies of the thing while the occurrence-analysed expression doesn't + -- Nevertheless, we *don't* occ-analyse before computing the size because the + -- size computation bales out after a while, whereas occurrence analysis does not. + -- + -- This can occasionally mean that the guidance is very pessimistic; + -- it gets fixed up next round. And it should be rare, because large + -- let-bound things that are dead are usually caught by preInlineUnconditionally +\end{code} %************************************************************************ %* * diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 1908667..3752d1d 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -382,7 +382,7 @@ instance Outputable UnfoldingGuidance where instance Outputable UnfoldingSource where ppr InlineCompulsory = ptext (sLit "Compulsory") ppr (InlineWrapper w) = ptext (sLit "Worker=") <> ppr w - ppr InlineRule = ptext (sLit "InlineRule") + ppr InlineStable = ptext (sLit "InlineStable") ppr InlineRhs = ptext (sLit "") instance Outputable Unfolding where @@ -407,8 +407,8 @@ instance Outputable Unfolding where , ptext (sLit "Expandable=") <> ppr exp , ptext (sLit "Guidance=") <> ppr g ] pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs - pp_rhs | isInlineRuleSource src = pp_tmpl - | otherwise = empty + pp_rhs | isStableSource src = pp_tmpl + | otherwise = empty -- Don't print the RHS or we get a quadratic -- blowup in the size of the printout! \end{code} diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index c886c8e..17333af 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -355,21 +355,29 @@ 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) + | otherwise + = case inlinePragmaSpec inline_prag of + EmptyInlineSpec -> (gbl_id, rhs) + NoInline -> (gbl_id, rhs) + Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs) + Inline -> inline_pair - | Just arity <- inlinePragmaSat inline_prag + where + inline_prag = idInlinePragma gbl_id + inlinable_unf = mkInlinableUnfolding rhs + inline_pair + | 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] - , let real_arity = dict_arity + arity + , let real_arity = dict_arity + arity -- NB: The arity in the InlineRule takes account of the dictionaries - = (gbl_id `setIdUnfolding` mkInlineRule rhs (Just real_arity), - etaExpand real_arity rhs) + = ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs + , etaExpand real_arity rhs) + + | otherwise + = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $ + (gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs) - | otherwise - = (gbl_id `setIdUnfolding` mkInlineRule rhs Nothing, rhs) - where - inline_prag = idInlinePragma gbl_id dictArity :: [Var] -> Arity -- Don't count coercion variables in arity diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 51f03c2..d73cd53 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 wrap_rhs (Just (length args)) + fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty) \end{code} diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 3310ffa..b24daea 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -460,15 +460,17 @@ rep_specialise nm ty ispec loc rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma -> DsM (Core TH.InlineSpecQ) rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline }) - | Nothing <- activation1 - = repInlineSpecNoPhase inline1 match1 | Just (flag, phase) <- activation1 - = repInlineSpecPhase inline1 match1 flag phase - | otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec" - where + = repInlineSpecPhase inline1 match1 flag phase + | otherwise + = repInlineSpecNoPhase inline1 match1 + where match1 = coreBool (rep_RuleMatchInfo match) activation1 = rep_Activation activation - inline1 = coreBool inline + inline1 = case inline of + Inline -> coreBool True + _other -> coreBool False + -- We have no representation for Inlinable rep_RuleMatchInfo FunLike = False rep_RuleMatchInfo ConLike = True diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index d392be2..0ab26ee 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -400,7 +400,7 @@ cvtInlineSpec Nothing = defaultInlinePragma cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo - , inl_inline = inline, inl_sat = Nothing } + , inl_inline = inl_spec, inl_sat = Nothing } where matchinfo = cvtRuleMatchInfo conlike opt_activation' = cvtActivation opt_activation @@ -408,6 +408,10 @@ cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) cvtRuleMatchInfo False = FunLike cvtRuleMatchInfo True = ConLike + inl_spec | inline = Inline + | otherwise = NoInline + -- Currently we have no way to say Inlinable + cvtActivation Nothing | inline = AlwaysActive | otherwise = NeverActive cvtActivation (Just (False, phase)) = ActiveBefore phase diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 4d3f619..ec85995 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -612,6 +612,19 @@ instance Binary InlinePragma where d <- get bh return (InlinePragma a b c d) +instance Binary InlineSpec where + put_ bh EmptyInlineSpec = putByte bh 0 + put_ bh Inline = putByte bh 1 + put_ bh Inlinable = putByte bh 2 + put_ bh NoInline = putByte bh 3 + + get bh = do h <- getByte bh + case h of + 0 -> return EmptyInlineSpec + 1 -> return Inline + 2 -> return Inlinable + _ -> return NoInline + instance Binary HsBang where put_ bh HsNoBang = putByte bh 0 put_ bh HsStrict = putByte bh 1 @@ -1188,8 +1201,9 @@ instance Binary IfaceInfoItem where _ -> do return HsNoCafRefs instance Binary IfaceUnfolding where - put_ bh (IfCoreUnfold e) = do + put_ bh (IfCoreUnfold s e) = do putByte bh 0 + put_ bh s put_ bh e put_ bh (IfInlineRule a b c d) = do putByte bh 1 @@ -1210,8 +1224,9 @@ instance Binary IfaceUnfolding where get bh = do h <- getByte bh case h of - 0 -> do e <- get bh - return (IfCoreUnfold e) + 0 -> do s <- get bh + e <- get bh + return (IfCoreUnfold s e) 1 -> do a <- get bh b <- get bh c <- get bh diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 282752b..c8348cb 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -210,7 +210,8 @@ data IfaceInfoItem -- only later attached to the Id. Partial reason: some are orphans. data IfaceUnfolding - = IfCoreUnfold IfaceExpr + = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding + | IfCompulsory IfaceExpr -- Only used for default methods, in fact | IfInlineRule Arity @@ -688,11 +689,13 @@ instance Outputable IfaceInfoItem where instance Outputable IfaceUnfolding where ppr (IfCompulsory e) = ptext (sLit "") <+> parens (ppr e) - ppr (IfCoreUnfold e) = parens (ppr e) + ppr (IfCoreUnfold s e) = (if s then ptext (sLit "") else empty) <+> parens (ppr e) ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") <+> ppr (a,uok,bok), pprParendIfaceExpr e] - ppr (IfWrapper a wkr) = ptext (sLit "Worker:") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a) - ppr (IfDFunUnfold ns) = ptext (sLit "DFun:") <+> brackets (pprWithCommas pprParendIfaceExpr ns) + ppr (IfWrapper a wkr) = ptext (sLit "Worker:") <+> ppr wkr + <+> parens (ptext (sLit "arity") <+> int a) + ppr (IfDFunUnfold ns) = ptext (sLit "DFun:") + <+> brackets (pprWithCommas pprParendIfaceExpr ns) -- ----------------------------------------------------------------------------- @@ -810,7 +813,7 @@ freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u freeNamesItem _ = emptyNameSet freeNamesIfUnfold :: IfaceUnfolding -> NameSet -freeNamesIfUnfold (IfCoreUnfold e) = freeNamesIfExpr e +freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e freeNamesIfUnfold (IfWrapper _ v) = unitNameSet v diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 68c6cf1..fd8fbdb 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1535,21 +1535,23 @@ toIfaceIdInfo id_info -------------------------- toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem -toIfUnfolding lb unf@(CoreUnfolding { uf_tmpl = rhs, uf_arity = arity - , uf_src = src, uf_guidance = guidance }) +toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity + , uf_src = src, uf_guidance = guidance }) = Just $ HsUnfold lb $ case src of - InlineRule {} + InlineStable -> case guidance of - UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok (toIfaceExpr rhs) - _other -> pprPanic "toIfUnfolding" (ppr unf) + UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok if_rhs + _other -> IfCoreUnfold True if_rhs InlineWrapper w -> IfWrapper arity (idName w) - InlineCompulsory -> IfCompulsory (toIfaceExpr rhs) - InlineRhs -> IfCoreUnfold (toIfaceExpr rhs) + InlineCompulsory -> IfCompulsory if_rhs + InlineRhs -> IfCoreUnfold False if_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 + if_rhs = toIfaceExpr rhs toIfUnfolding lb (DFunUnfolding _ar _con ops) = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops))) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index fde3146..07b0b72 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -1008,11 +1008,14 @@ tcIdInfo ignore_prags name ty info \begin{code} tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding -tcUnfolding name _ info (IfCoreUnfold if_expr) +tcUnfolding name _ info (IfCoreUnfold stable if_expr) = do { mb_expr <- tcPragExpr name if_expr + ; let unf_src = if stable then InlineStable else InlineRhs ; return (case mb_expr of - Nothing -> NoUnfolding - Just expr -> mkTopUnfolding is_bottoming expr) } + Nothing -> NoUnfolding + Just expr -> mkUnfolding unf_src + True {- Top level -} + is_bottoming expr) } where -- Strictness should occur before unfolding! is_bottoming = case strictnessInfo info of @@ -1029,7 +1032,7 @@ 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 + Just expr -> mkCoreUnfolding True InlineStable expr arity (UnfWhen unsat_ok boring_ok)) } diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 8ce4dcd..7d04563 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -725,7 +725,7 @@ addExternal expose_all id = (new_needed_ids, show_unfold) = expose_all -- 'expose_all' says to expose all -- unfoldings willy-nilly - || isInlineRuleSource unf_source -- Always expose things whose + || isStableSource unf_source -- Always expose things whose -- source is an inline rule || not (bottoming_fn -- No need to inline bottom functions @@ -1098,7 +1098,7 @@ tidyUnfolding tidy_env _ _ (DFunUnfolding ar con ids) = DFunUnfolding ar con (map (tidyExpr tidy_env) ids) tidyUnfolding tidy_env tidy_rhs strict_sig unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) - | isInlineRuleSource src + | isStableSource src = unf { uf_tmpl = tidyExpr tidy_env unf_rhs, -- Preserves OccInfo uf_src = tidyInl tidy_env src } | otherwise diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index cadd56d..0fa3256 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -66,6 +66,7 @@ import UniqFM import DynFlags import Module import Ctype +import BasicTypes ( InlineSpec(..), RuleMatchInfo(..) ) import Util ( readRational ) import Control.Monad @@ -462,8 +463,7 @@ data Token | ITusing -- Pragmas - | ITinline_prag Bool -- True <=> INLINE, False <=> NOINLINE - | ITinline_conlike_prag Bool -- same + | ITinline_prag InlineSpec RuleMatchInfo | ITspec_prag -- SPECIALISE | ITspec_inline_prag Bool -- SPECIALISE INLINE (or NOINLINE) | ITsource_prag @@ -2216,8 +2216,9 @@ ignoredPrags = Map.fromList (map ignored pragmas) pragmas = options_pragmas ++ ["cfiles", "contract"] oneWordPrags = Map.fromList([("rules", rulePrag), - ("inline", token (ITinline_prag True)), - ("notinline", token (ITinline_prag False)), + ("inline", token (ITinline_prag Inline FunLike)), + ("inlinable", token (ITinline_prag Inlinable FunLike)), + ("notinline", token (ITinline_prag NoInline FunLike)), ("specialize", token ITspec_prag), ("source", token ITsource_prag), ("warning", token ITwarning_prag), @@ -2228,8 +2229,8 @@ oneWordPrags = Map.fromList([("rules", rulePrag), ("unpack", token ITunpack_prag), ("ann", token ITann_prag)]) -twoWordPrags = Map.fromList([("inline conlike", token (ITinline_conlike_prag True)), - ("notinline conlike", token (ITinline_conlike_prag False)), +twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)), + ("notinline conlike", token (ITinline_prag NoInline ConLike)), ("specialize inline", token (ITspec_inline_prag True)), ("specialize notinline", token (ITspec_inline_prag False))]) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index e78b1ca..7ab7c44 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -56,8 +56,7 @@ import StaticFlags ( opt_SccProfilingOn, opt_Hpc ) import Type ( Kind, liftedTypeKind, unliftedTypeKind ) import Coercion ( mkArrowKind ) import Class ( FunDep ) -import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), - Activation(..), RuleMatchInfo(..), defaultInlinePragma ) +import BasicTypes import DynFlags import OrdList import HaddockUtils @@ -261,8 +260,7 @@ incorrect. 'by' { L _ ITby } -- for list transform extension 'using' { L _ ITusing } -- for list transform extension - '{-# INLINE' { L _ (ITinline_prag _) } - '{-# INLINE_CONLIKE' { L _ (ITinline_conlike_prag _) } + '{-# INLINE' { L _ (ITinline_prag _ _) } '{-# SPECIALISE' { L _ ITspec_prag } '{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _) } '{-# SOURCE' { L _ ITsource_prag } @@ -1238,14 +1236,12 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } | infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1)))) | n <- unLoc $3 ] } | '{-# INLINE' activation qvar '#-}' - { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma $2 FunLike (getINLINE $1)))) } - | '{-# INLINE_CONLIKE' activation qvar '#-}' - { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma $2 ConLike (getINLINE_CONLIKE $1)))) } + { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) } | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}' { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlinePragma) | t <- $4] } | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' - { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma $2 FunLike (getSPEC_INLINE $1))) + { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma (getSPEC_INLINE $1) $2)) | t <- $5] } | '{-# SPECIALISE' 'instance' inst_type '#-}' { LL $ unitOL (LL $ SigD (SpecInstSig $3)) } @@ -1988,9 +1984,9 @@ getPRIMWORD (L _ (ITprimword x)) = x getPRIMFLOAT (L _ (ITprimfloat x)) = x getPRIMDOUBLE (L _ (ITprimdouble x)) = x getTH_ID_SPLICE (L _ (ITidEscape x)) = x -getINLINE (L _ (ITinline_prag b)) = b -getINLINE_CONLIKE (L _ (ITinline_conlike_prag b)) = b -getSPEC_INLINE (L _ (ITspec_inline_prag b)) = b +getINLINE (L _ (ITinline_prag inl conl)) = (inl,conl) +getSPEC_INLINE (L _ (ITspec_inline_prag True)) = (Inline, FunLike) +getSPEC_INLINE (L _ (ITspec_inline_prag False)) = (NoInline,FunLike) getDOCNEXT (L _ (ITdocCommentNext x)) = x getDOCPREV (L _ (ITdocCommentPrev x)) = x diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 7d806ed..548b111 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -55,7 +55,7 @@ import TypeRep ( Kind ) import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace ) import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, - InlinePragma(..) ) + InlinePragma(..), InlineSpec(..) ) import Lexer import TysWiredIn ( unitTyCon ) import ForeignCall @@ -937,9 +937,9 @@ mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) } -mkInlinePragma :: Maybe Activation -> RuleMatchInfo -> Bool -> InlinePragma +mkInlinePragma :: (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma -- The Maybe is because the user can omit the activation spec (and usually does) -mkInlinePragma mb_act match_info inl +mkInlinePragma (inl, match_info) mb_act = InlinePragma { inl_inline = inl , inl_sat = Nothing , inl_act = act @@ -947,11 +947,10 @@ mkInlinePragma mb_act match_info inl where act = case mb_act of Just act -> act - Nothing | inl -> AlwaysActive - | otherwise -> NeverActive - -- If no specific phase is given then: - -- NOINLINE => NeverActive - -- INLINE => Active + Nothing -> -- No phase specified + case inl of + NoInline -> NeverActive + _other -> AlwaysActive ----------------------------------------------------------------------------- -- utilities for foreign declarations diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index a37b5f1..3dca9a8 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -537,7 +537,7 @@ reOrderCycle depth (bind : binds) pairs | isDFunId bndr = 9 -- Never choose a DFun as a loop breaker -- Note [DFuns should not be loop breakers] - | Just (inl_source, _) <- isInlineRule_maybe (idUnfolding bndr) + | Just (inl_source, _) <- isStableUnfolding_maybe (idUnfolding bndr) = case inl_source of InlineWrapper {} -> 10 -- Note [INLINE pragmas] _other -> 3 -- Data structures are more important than this diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index ef0c7f2..23874bf 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -859,7 +859,7 @@ abstractVars dest_lvl (_, lvl_env, _, id_env) fvs -- We are going to lambda-abstract, so nuke any IdInfo, -- and add the tyvars of the Id (if necessary) - zap v | isId v = WARN( isInlineRule (idUnfolding v) || + zap v | isId v = WARN( isStableUnfolding (idUnfolding v) || not (isEmptySpecInfo (idSpecialisation v)), text "absVarsOf: discarding info on" <+> ppr v ) setIdInfo v vanillaIdInfo diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 0a1fdd2..5d8e0a2 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -28,8 +28,9 @@ import CoreMonad ( SimplifierSwitch(..), Tick(..) ) import CoreSyn import Demand ( isStrictDmd, splitStrictSig ) import PprCore ( pprParendExpr, pprCoreExpr ) -import CoreUnfold ( mkUnfolding, mkCoreUnfolding, mkInlineRule, - exprIsConApp_maybe, callSiteInline, CallCtxt(..) ) +import CoreUnfold ( mkUnfolding, mkCoreUnfolding + , mkInlineUnfolding, mkSimpleUnfolding + , exprIsConApp_maybe, callSiteInline, CallCtxt(..) ) import CoreUtils import qualified CoreSubst import CoreArity ( exprArity ) @@ -713,7 +714,7 @@ simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops) simplUnfolding env top_lvl id _ _ (CoreUnfolding { uf_tmpl = expr, uf_arity = arity , uf_src = src, uf_guidance = guide }) - | isInlineRuleSource src + | isStableSource src = do { expr' <- simplExpr rule_env expr ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) } @@ -724,7 +725,7 @@ simplUnfolding env top_lvl id _ _ -- See Note [Simplifying gently inside InlineRules] in SimplUtils simplUnfolding _ top_lvl id _occ_info new_rhs _ - = return (mkUnfolding (isTopLevel top_lvl) (isBottomingId id) new_rhs) + = return (mkUnfolding InlineRhs (isTopLevel top_lvl) (isBottomingId id) new_rhs) -- We make an unfolding *even for loop-breakers*. -- Reason: (a) It might be useful to know that they are WHNF -- (b) In TidyPgm we currently assume that, if we want to @@ -1789,7 +1790,7 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs) addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv addBinderUnfolding env bndr rhs - = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False False rhs) + = modifyInScope env (bndr `setIdUnfolding` mkSimpleUnfolding rhs) addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv addBinderOtherCon env bndr cons @@ -2016,7 +2017,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') DataAlt dc -> setIdUnfolding case_bndr unf where -- See Note [Case binders and join points] - unf = mkInlineRule rhs Nothing + unf = mkInlineUnfolding Nothing rhs rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty) ++ varsToCoreExprs bndrs') diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 2d0b383..47a4f05 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -11,7 +11,7 @@ module Specialise ( specProgram ) where import Id import TcType import CoreSubst -import CoreUnfold ( mkUnfolding, mkInlineRule ) +import CoreUnfold ( mkSimpleUnfolding, mkInlineUnfolding ) import VarSet import VarEnv import CoreSyn @@ -706,7 +706,7 @@ specCase subst scrut' case_bndr [(con, args, rhs)] loc = getSrcSpan name add_unf sc_flt sc_rhs -- Sole purpose: make sc_flt respond True to interestingDictId - = setIdUnfolding sc_flt (mkUnfolding False False sc_rhs) + = setIdUnfolding sc_flt (mkSimpleUnfolding sc_rhs) arg_set = mkVarSet args' is_flt_sc_arg var = isId var @@ -908,7 +908,7 @@ specDefn subst body_uds fn rhs -- Figure out whether the function has an INLINE pragma -- See Note [Inline specialisations] fn_has_inline_rule :: Maybe Bool -- Derive sat-flag from existing thing - fn_has_inline_rule = case isInlineRule_maybe fn_unf of + fn_has_inline_rule = case isStableUnfolding_maybe fn_unf of Just (_,sat) -> Just sat Nothing -> Nothing @@ -1015,7 +1015,7 @@ specDefn subst body_uds fn rhs = let mb_spec_arity = if sat then Just spec_arity else Nothing in - spec_f_w_arity `setIdUnfolding` mkInlineRule spec_rhs mb_spec_arity + spec_f_w_arity `setIdUnfolding` mkInlineUnfolding mb_spec_arity spec_rhs | otherwise = spec_f_w_arity @@ -1048,7 +1048,7 @@ bindAuxiliaryDicts subst triples = go subst [] triples | otherwise = go subst_w_unf (NonRec dx_id dx : binds) pairs where - dx_id1 = dx_id `setIdUnfolding` mkUnfolding False False dx + dx_id1 = dx_id `setIdUnfolding` mkSimpleUnfolding dx subst_w_unf = extendIdSubst subst d (Var dx_id1) -- Important! We're going to substitute dx_id1 for d -- and we want it to look "interesting", else we won't gather *any* diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs index 7a56c33..d329b5a 100644 --- a/compiler/stranal/WorkWrap.lhs +++ b/compiler/stranal/WorkWrap.lhs @@ -7,20 +7,16 @@ module WorkWrap ( wwTopBinds, mkWrapper ) where import CoreSyn -import CoreUnfold ( certainlyWillInline, mkInlineRule, mkWwInlineRule ) +import CoreUnfold ( certainlyWillInline, mkInlineUnfolding, mkWwInlineRule ) import CoreUtils ( exprType, exprIsHNF ) import CoreArity ( exprArity ) import Var import Id import Type ( Type ) import IdInfo -import Demand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), - Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent - ) +import Demand import UniqSupply -import BasicTypes ( RecFlag(..), isNonRec, isNeverActive, - Activation(..), InlinePragma(..), - inlinePragmaActivation, inlinePragmaRuleMatchInfo ) +import BasicTypes import VarEnv ( isEmptyVarEnv ) import Maybes ( orElse ) import WwLib @@ -276,7 +272,7 @@ checkSize fn_id rhs thing_inside | otherwise = thing_inside where unfolding = idUnfolding fn_id - inline_rule = mkInlineRule rhs Nothing + inline_rule = mkInlineUnfolding Nothing rhs --------------------- splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Expr Var @@ -314,7 +310,7 @@ splitFun fn_id fn_info wrap_dmds res_info rhs -- arity is consistent with the demand type goes through wrap_rhs = wrap_fn work_id - wrap_prag = InlinePragma { inl_inline = True + wrap_prag = InlinePragma { inl_inline = Inline , inl_sat = Nothing , inl_act = ActiveAfter 0 , inl_rule = rule_match_info } diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index a296e89..8e04833 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -15,7 +15,7 @@ import Vectorise.Monad import HscTypes hiding ( MonadThings(..) ) import Module ( PackageId ) import CoreSyn -import CoreUnfold ( mkInlineRule ) +import CoreUnfold ( mkInlineUnfolding ) import CoreFVs import CoreMonad ( CoreM, getHscEnv ) import FamInstEnv ( extendFamInstEnvList ) @@ -177,7 +177,7 @@ vectTopBinder var inline expr return var' where unfolding = case inline of - Inline arity -> mkInlineRule expr (Just arity) + Inline arity -> mkInlineUnfolding (Just arity) expr DontInline -> noUnfolding diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index 7831c93..42efe37 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -22,7 +22,7 @@ import Var import VarEnv import VarSet import Id -import BasicTypes +import BasicTypes( isLoopBreaker ) import Literal import TysWiredIn import TysPrim diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index 8e26ed9..06bd789 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -182,7 +182,7 @@ vectDataConWorkers orig_tc vect_tc arr_tc raw_worker <- cloneId mkVectOcc orig_worker (exprType body) let vect_worker = raw_worker `setIdUnfolding` - mkInlineRule body (Just arity) + mkInlineUnfolding (Just arity) body defGlobalVar orig_worker vect_worker return (vect_worker, body) where diff --git a/compiler/vectorise/Vectorise/Type/PADict.hs b/compiler/vectorise/Vectorise/Type/PADict.hs index ef5c8d5..d3d2213 100644 --- a/compiler/vectorise/Vectorise/Type/PADict.hs +++ b/compiler/vectorise/Vectorise/Type/PADict.hs @@ -56,7 +56,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 body (Just (length args)) + `setIdUnfolding` mkInlineUnfolding (Just (length args)) body `setInlinePragma` alwaysInlinePragma hoistBinding var body return var diff --git a/compiler/vectorise/Vectorise/Utils/Closure.hs b/compiler/vectorise/Vectorise/Utils/Closure.hs index b70ecb4..6b8688c 100644 --- a/compiler/vectorise/Vectorise/Utils/Closure.hs +++ b/compiler/vectorise/Vectorise/Utils/Closure.hs @@ -24,7 +24,7 @@ import TyCon import DataCon import MkId import TysWiredIn -import BasicTypes +import BasicTypes( Boxity(..) ) import FastString diff --git a/compiler/vectorise/Vectorise/Utils/Hoisting.hs b/compiler/vectorise/Vectorise/Utils/Hoisting.hs index 9cce416..12b1b6f 100644 --- a/compiler/vectorise/Vectorise/Utils/Hoisting.hs +++ b/compiler/vectorise/Vectorise/Utils/Hoisting.hs @@ -22,7 +22,7 @@ import CoreUnfold import Type import Var import Id -import BasicTypes +import BasicTypes( Arity ) import FastString import Control.Monad @@ -58,7 +58,7 @@ hoistExpr fs expr inl where mk_inline var = case inl of Inline arity -> var `setIdUnfolding` - mkInlineRule expr (Just arity) + mkInlineUnfolding (Just arity) expr DontInline -> var