Skip to content

GitLab

Commit a51fe79e authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Implement INLINABLE pragma 

Implements Trac #4299.  Documentation to come.
parent 0ccc12b6
Hide whitespace changes
Inline Side-by-side
Showing with 238 additions and 166 deletions
compiler/basicTypes/BasicTypes.lhs
View file @ a51fe79e
......@@ -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
......
compiler/basicTypes/MkId.lhs
View file @ a51fe79e
......@@ -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 $
......
compiler/coreSyn/CoreFVs.lhs
View file @ a51fe79e
......@@ -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
......
compiler/coreSyn/CoreSubst.lhs
View file @ a51fe79e
......@@ -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
......
compiler/coreSyn/CoreSyn.lhs
View file @ a51fe79e
......@@ -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
......
compiler/coreSyn/CoreUnfold.lhs
View file @ a51fe79e
......@@ -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}
%************************************************************************
%* *
......
compiler/coreSyn/PprCore.lhs
View file @ a51fe79e
......@@ -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 "<vanilla>")
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}
......
compiler/deSugar/DsBinds.lhs
View file @ a51fe79e
......@@ -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
......
compiler/deSugar/DsForeign.lhs
View file @ a51fe79e
......@@ -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}
......
compiler/deSugar/DsMeta.hs
View file @ a51fe79e
......@@ -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
......
compiler/hsSyn/Convert.lhs
View file @ a51fe79e
......@@ -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
......
compiler/iface/BinIface.hs
View file @ a51fe79e
......@@ -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
......
compiler/iface/IfaceSyn.lhs
View file @ a51fe79e
......@@ -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 "<compulsory>") <+> parens (ppr e)
ppr (IfCoreUnfold e) = parens (ppr e)
ppr (IfCoreUnfold s e) = (if s then ptext (sLit "<stable>") 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
......
compiler/iface/MkIface.lhs
View file @ a51fe79e
......@@ -1535,21 +1535,23 @@ toIfaceIdInfo id_info