Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Shayne Fletcher
Glasgow Haskell Compiler
Commits
a51fe79e
Commit
a51fe79e
authored
Sep 15, 2010
by
simonpj@microsoft.com
Browse files
Implement INLINABLE pragma
Implements Trac #4299. Documentation to come.
parent
0ccc12b6
Changes
30
Hide whitespace changes
Inline
Side-by-side
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 =
Tru
e }
alwaysInlinePragma = defaultInlinePragma { inl_inline =
Inlin
e }
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
= pp
r
inl
ine <> 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 = mkInline
Rule wrap_rhs
(Just (length dict_args + length id_args))
wrap_unf = mkInline
Unfolding
(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 }
| is
InlineRu
leSource src
| is
Stab
leSource 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 (is
InlineRu
leSource src) --
Always zap a CoreU
nfolding, to save substitution work
| not (is
Stab
leSource src) --
Zap an unstable u
nfolding, to save substitution work
= NoUnfolding
| otherwise
-- But keep a
n InlineRul
e!
| otherwise -- But keep a
stable on
e!
= 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]
Inline
Rule
-- It's not a wrapper any more, but still inline it!
Inline
Stable
-- 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]
Inline
Ru
le
Inline
Stab
le
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 <=> applic
atio
n 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
is
InlineRule
_maybe _ = Nothing
is
StableUnfolding
_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 }) = is
InlineRu
leSource src
isStableUnfolding (CoreUnfolding { uf_src = src }) = is
Stab
leSource 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 Inline
Rule
= ptext (sLit "Inline
Ru
le")
ppr Inline
Stable
= ptext (sLit "Inline
Stab
le")
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 | is
InlineRu
leSource src = pp_tmpl
| otherwise
= empty
pp_rhs | is
Stab
leSource 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` mkInline
Rule wrap_rhs
(Just (length args))
fn_id_w_inl = fn_id `setIdUnfolding` mkInline
Unfolding
(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 = inl
ine
, 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
--------------------------