Commit 4bc25e8c authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Add the notion of "constructor-like" Ids for rule-matching

This patch adds an optional CONLIKE modifier to INLINE/NOINLINE pragmas, 
   {-# NOINLINE CONLIKE [1] f #-}
The effect is to allow applications of 'f' to be expanded in a potential
rule match.  Example
  {-# RULE "r/f" forall v. r (f v) = f (v+1) #-}

Consider the term
     let x = f v in ..x...x...(r x)...
Normally the (r x) would not match the rule, because GHC would be scared
about duplicating the redex (f v). However the CONLIKE modifier says to
treat 'f' like a constructor in this situation, and "look through" the
unfolding for x.  So (r x) fires, yielding (f (v+1)).

The main changes are:
  - Syntax

  - The inlinePragInfo field of an IdInfo has a RuleMatchInfo
    component, which records whether or not the Id is CONLIKE.
    Of course, this needs to be serialised in interface files too.

  - The occurrence analyser (OccAnal) and simplifier (Simplify) treat
    CONLIKE thing like constructors, by ANF-ing them

  - New function coreUtils.exprIsExpandable is like exprIsCheap, but
    additionally spots applications of CONLIKE functions

  - A CoreUnfolding has a field that caches exprIsExpandable

  - The rule matcher consults this field.  See 
    Note [Expanding variables] in Rules.lhs.

On the way I fixed a lurking variable bug in the way variables are
expanded.  See Note [Do not expand locally-bound variables] in
Rule.lhs.  I also did a bit of reformatting and refactoring in
Rules.lhs, so the module has more lines changed than are really
different.
parent bd78c94a
...@@ -55,6 +55,10 @@ module BasicTypes( ...@@ -55,6 +55,10 @@ module BasicTypes(
CompilerPhase, CompilerPhase,
Activation(..), isActive, isNeverActive, isAlwaysActive, Activation(..), isActive, isNeverActive, isAlwaysActive,
RuleMatchInfo(..), isConLike, isFunLike,
InlinePragma(..), defaultInlinePragma, isDefaultInlinePragma,
inlinePragmaActivation, inlinePragmaRuleMatchInfo,
setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
InlineSpec(..), defaultInlineSpec, alwaysInlineSpec, neverInlineSpec, InlineSpec(..), defaultInlineSpec, alwaysInlineSpec, neverInlineSpec,
SuccessFlag(..), succeeded, failed, successIf SuccessFlag(..), succeeded, failed, successIf
...@@ -580,35 +584,94 @@ data Activation = NeverActive ...@@ -580,35 +584,94 @@ data Activation = NeverActive
| ActiveAfter CompilerPhase -- Active in this phase and later | ActiveAfter CompilerPhase -- Active in this phase and later
deriving( Eq ) -- Eq used in comparing rules in HsDecls deriving( Eq ) -- Eq used in comparing rules in HsDecls
data RuleMatchInfo = ConLike
| FunLike
deriving( Eq )
isConLike :: RuleMatchInfo -> Bool
isConLike ConLike = True
isConLike _ = False
isFunLike :: RuleMatchInfo -> Bool
isFunLike FunLike = True
isFunLike _ = False
data InlinePragma
= InlinePragma
Activation -- Says during which phases inlining is allowed
RuleMatchInfo -- Should the function be treated like a constructor?
deriving( Eq )
defaultInlinePragma :: InlinePragma
defaultInlinePragma = InlinePragma AlwaysActive FunLike
isDefaultInlinePragma :: InlinePragma -> Bool
isDefaultInlinePragma (InlinePragma activation match_info)
= isAlwaysActive activation && isFunLike match_info
inlinePragmaActivation :: InlinePragma -> Activation
inlinePragmaActivation (InlinePragma activation _) = activation
inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo
inlinePragmaRuleMatchInfo (InlinePragma _ info) = info
setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma
setInlinePragmaActivation (InlinePragma _ info) activation
= InlinePragma activation info
setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma
setInlinePragmaRuleMatchInfo (InlinePragma activation _) info
= InlinePragma activation info
data InlineSpec data InlineSpec
= Inline = Inline
Activation -- Says during which phases inlining is allowed InlinePragma
Bool -- True <=> INLINE Bool -- True <=> INLINE
-- False <=> NOINLINE -- False <=> NOINLINE
deriving( Eq ) deriving( Eq )
defaultInlineSpec, alwaysInlineSpec, neverInlineSpec :: InlineSpec defaultInlineSpec :: InlineSpec
alwaysInlineSpec, neverInlineSpec :: RuleMatchInfo -> InlineSpec
defaultInlineSpec = Inline AlwaysActive False -- Inlining is OK, but not forced defaultInlineSpec = Inline defaultInlinePragma False
alwaysInlineSpec = Inline AlwaysActive True -- INLINE always -- Inlining is OK, but not forced
neverInlineSpec = Inline NeverActive False -- NOINLINE alwaysInlineSpec match_info
= Inline (InlinePragma AlwaysActive match_info) True
-- INLINE always
neverInlineSpec match_info
= Inline (InlinePragma NeverActive match_info) False
-- NOINLINE
instance Outputable Activation where instance Outputable Activation where
ppr NeverActive = ptext (sLit "NEVER") ppr NeverActive = ptext (sLit "NEVER")
ppr AlwaysActive = ptext (sLit "ALWAYS") ppr AlwaysActive = ptext (sLit "ALWAYS")
ppr (ActiveBefore n) = brackets (char '~' <> int n) ppr (ActiveBefore n) = brackets (char '~' <> int n)
ppr (ActiveAfter n) = brackets (int n) ppr (ActiveAfter n) = brackets (int n)
instance Outputable RuleMatchInfo where
ppr ConLike = ptext (sLit "CONLIKE")
ppr FunLike = ptext (sLit "FUNLIKE")
instance Outputable InlinePragma where
ppr (InlinePragma activation FunLike)
= ppr activation
ppr (InlinePragma activation match_info)
= ppr match_info <+> ppr activation
instance Outputable InlineSpec where instance Outputable InlineSpec where
ppr (Inline act is_inline) ppr (Inline (InlinePragma act match_info) is_inline)
| is_inline = ptext (sLit "INLINE") | is_inline = ptext (sLit "INLINE")
<> case act of <+> ppr_match_info
AlwaysActive -> empty <+> case act of
_ -> ppr act AlwaysActive -> empty
_ -> ppr act
| otherwise = ptext (sLit "NOINLINE") | otherwise = ptext (sLit "NOINLINE")
<> case act of <+> ppr_match_info
NeverActive -> empty <+> case act of
_ -> ppr act NeverActive -> empty
_ -> ppr act
where
ppr_match_info = if isFunLike match_info then empty else ppr match_info
isActive :: CompilerPhase -> Activation -> Bool isActive :: CompilerPhase -> Activation -> Bool
isActive _ NeverActive = False isActive _ NeverActive = False
......
...@@ -53,12 +53,13 @@ module Id ( ...@@ -53,12 +53,13 @@ module Id (
isPrimOpId, isPrimOpId_maybe, isPrimOpId, isPrimOpId_maybe,
isFCallId, isFCallId_maybe, isFCallId, isFCallId_maybe,
isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon, isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,
isBottomingId, idIsFrom, isConLikeId, isBottomingId, idIsFrom,
isTickBoxOp, isTickBoxOp_maybe, isTickBoxOp, isTickBoxOp_maybe,
hasNoBinding, hasNoBinding,
-- ** Inline pragma stuff -- ** Inline pragma stuff
idInlinePragma, setInlinePragma, modifyInlinePragma, idInlinePragma, setInlinePragma, modifyInlinePragma,
idInlineActivation, setInlineActivation, idRuleMatchInfo,
-- ** One-shot lambdas -- ** One-shot lambdas
isOneShotBndr, isOneShotLambda, isStateHackType, isOneShotBndr, isOneShotLambda, isStateHackType,
...@@ -599,14 +600,26 @@ The inline pragma tells us to be very keen to inline this Id, but it's still ...@@ -599,14 +600,26 @@ The inline pragma tells us to be very keen to inline this Id, but it's still
OK not to if optimisation is switched off. OK not to if optimisation is switched off.
\begin{code} \begin{code}
idInlinePragma :: Id -> InlinePragInfo idInlinePragma :: Id -> InlinePragma
idInlinePragma id = inlinePragInfo (idInfo id) idInlinePragma id = inlinePragInfo (idInfo id)
setInlinePragma :: Id -> InlinePragInfo -> Id setInlinePragma :: Id -> InlinePragma -> Id
setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id
modifyInlinePragma :: Id -> (InlinePragInfo -> InlinePragInfo) -> Id modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id
modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id
idInlineActivation :: Id -> Activation
idInlineActivation id = inlinePragmaActivation (idInlinePragma id)
setInlineActivation :: Id -> Activation -> Id
setInlineActivation id act = modifyInlinePragma id (\(InlinePragma _ match_info) -> InlinePragma act match_info)
idRuleMatchInfo :: Id -> RuleMatchInfo
idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id)
isConLikeId :: Id -> Bool
isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id)
\end{code} \end{code}
......
...@@ -329,7 +329,7 @@ data IdInfo ...@@ -329,7 +329,7 @@ data IdInfo
unfoldingInfo :: Unfolding, -- ^ The 'Id's unfolding unfoldingInfo :: Unfolding, -- ^ The 'Id's unfolding
cafInfo :: CafInfo, -- ^ 'Id' CAF info cafInfo :: CafInfo, -- ^ 'Id' CAF info
lbvarInfo :: LBVarInfo, -- ^ Info about a lambda-bound variable, if the 'Id' is one lbvarInfo :: LBVarInfo, -- ^ Info about a lambda-bound variable, if the 'Id' is one
inlinePragInfo :: InlinePragInfo, -- ^ Any inline pragma atached to the 'Id' inlinePragInfo :: InlinePragma, -- ^ Any inline pragma atached to the 'Id'
occInfo :: OccInfo, -- ^ How the 'Id' occurs in the program occInfo :: OccInfo, -- ^ How the 'Id' occurs in the program
newStrictnessInfo :: Maybe StrictSig, -- ^ Id strictness information. Reason for Maybe: newStrictnessInfo :: Maybe StrictSig, -- ^ Id strictness information. Reason for Maybe:
...@@ -378,7 +378,7 @@ setWorkerInfo :: IdInfo -> WorkerInfo -> IdInfo ...@@ -378,7 +378,7 @@ setWorkerInfo :: IdInfo -> WorkerInfo -> IdInfo
setWorkerInfo info wk = wk `seq` info { workerInfo = wk } setWorkerInfo info wk = wk `seq` info { workerInfo = wk }
setSpecInfo :: IdInfo -> SpecInfo -> IdInfo setSpecInfo :: IdInfo -> SpecInfo -> IdInfo
setSpecInfo info sp = sp `seq` info { specInfo = sp } setSpecInfo info sp = sp `seq` info { specInfo = sp }
setInlinePragInfo :: IdInfo -> InlinePragInfo -> IdInfo setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo
setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr }
setOccInfo :: IdInfo -> OccInfo -> IdInfo setOccInfo :: IdInfo -> OccInfo -> IdInfo
setOccInfo info oc = oc `seq` info { occInfo = oc } setOccInfo info oc = oc `seq` info { occInfo = oc }
...@@ -434,7 +434,7 @@ vanillaIdInfo ...@@ -434,7 +434,7 @@ vanillaIdInfo
workerInfo = NoWorker, workerInfo = NoWorker,
unfoldingInfo = noUnfolding, unfoldingInfo = noUnfolding,
lbvarInfo = NoLBVarInfo, lbvarInfo = NoLBVarInfo,
inlinePragInfo = AlwaysActive, inlinePragInfo = defaultInlinePragma,
occInfo = NoOccInfo, occInfo = NoOccInfo,
newDemandInfo = Nothing, newDemandInfo = Nothing,
newStrictnessInfo = Nothing newStrictnessInfo = Nothing
...@@ -493,7 +493,7 @@ ppArityInfo n = hsep [ptext (sLit "Arity"), int n] ...@@ -493,7 +493,7 @@ ppArityInfo n = hsep [ptext (sLit "Arity"), int n]
-- --
-- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves -- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves
-- entirely as a way to inhibit inlining until we want it -- entirely as a way to inhibit inlining until we want it
type InlinePragInfo = Activation type InlinePragInfo = InlinePragma
\end{code} \end{code}
......
...@@ -42,7 +42,8 @@ module CoreSyn ( ...@@ -42,7 +42,8 @@ module CoreSyn (
-- ** Predicates and deconstruction on 'Unfolding' -- ** Predicates and deconstruction on 'Unfolding'
unfoldingTemplate, maybeUnfoldingTemplate, otherCons, unfoldingTemplate, maybeUnfoldingTemplate, otherCons,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding, isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
isExpandableUnfolding, isCompulsoryUnfolding,
hasUnfolding, hasSomeUnfolding, neverUnfold, hasUnfolding, hasSomeUnfolding, neverUnfold,
-- * Strictness -- * Strictness
...@@ -412,6 +413,7 @@ data Unfolding ...@@ -412,6 +413,7 @@ data Unfolding
Bool Bool
Bool Bool
Bool Bool
Bool
UnfoldingGuidance UnfoldingGuidance
-- ^ An unfolding with redundant cached information. Parameters: -- ^ An unfolding with redundant cached information. Parameters:
-- --
...@@ -455,8 +457,8 @@ mkOtherCon :: [AltCon] -> Unfolding ...@@ -455,8 +457,8 @@ mkOtherCon :: [AltCon] -> Unfolding
mkOtherCon = OtherCon mkOtherCon = OtherCon
seqUnfolding :: Unfolding -> () seqUnfolding :: Unfolding -> ()
seqUnfolding (CoreUnfolding e top b1 b2 g) seqUnfolding (CoreUnfolding e top b1 b2 b3 g)
= seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` seqGuidance g
seqUnfolding _ = () seqUnfolding _ = ()
seqGuidance :: UnfoldingGuidance -> () seqGuidance :: UnfoldingGuidance -> ()
...@@ -467,15 +469,15 @@ seqGuidance _ = () ...@@ -467,15 +469,15 @@ seqGuidance _ = ()
\begin{code} \begin{code}
-- | Retrieves the template of an unfolding: panics if none is known -- | Retrieves the template of an unfolding: panics if none is known
unfoldingTemplate :: Unfolding -> CoreExpr unfoldingTemplate :: Unfolding -> CoreExpr
unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr unfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = expr
unfoldingTemplate (CompulsoryUnfolding expr) = expr unfoldingTemplate (CompulsoryUnfolding expr) = expr
unfoldingTemplate _ = panic "getUnfoldingTemplate" unfoldingTemplate _ = panic "getUnfoldingTemplate"
-- | Retrieves the template of an unfolding if possible -- | Retrieves the template of an unfolding if possible
maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = Just expr
maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
maybeUnfoldingTemplate _ = Nothing maybeUnfoldingTemplate _ = Nothing
-- | The constructors that the unfolding could never be: -- | The constructors that the unfolding could never be:
-- returns @[]@ if no information is available -- returns @[]@ if no information is available
...@@ -486,21 +488,25 @@ otherCons _ = [] ...@@ -486,21 +488,25 @@ otherCons _ = []
-- | Determines if it is certainly the case that the unfolding will -- | Determines if it is certainly the case that the unfolding will
-- yield a value (something in HNF): returns @False@ if unsure -- yield a value (something in HNF): returns @False@ if unsure
isValueUnfolding :: Unfolding -> Bool isValueUnfolding :: Unfolding -> Bool
isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald isValueUnfolding (CoreUnfolding _ _ is_evald _ _ _) = is_evald
isValueUnfolding _ = False isValueUnfolding _ = False
-- | Determines if it possibly the case that the unfolding will -- | Determines if it possibly the case that the unfolding will
-- yield a value. Unlike 'isValueUnfolding' it returns @True@ -- yield a value. Unlike 'isValueUnfolding' it returns @True@
-- for 'OtherCon' -- for 'OtherCon'
isEvaldUnfolding :: Unfolding -> Bool isEvaldUnfolding :: Unfolding -> Bool
isEvaldUnfolding (OtherCon _) = True isEvaldUnfolding (OtherCon _) = True
isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _ _) = is_evald
isEvaldUnfolding _ = False isEvaldUnfolding _ = False
-- | Is the thing we will unfold into certainly cheap? -- | Is the thing we will unfold into certainly cheap?
isCheapUnfolding :: Unfolding -> Bool isCheapUnfolding :: Unfolding -> Bool
isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _ _) = is_cheap
isCheapUnfolding _ = False isCheapUnfolding _ = False
isExpandableUnfolding :: Unfolding -> Bool
isExpandableUnfolding (CoreUnfolding _ _ _ _ is_expable _) = is_expable
isExpandableUnfolding _ = False
-- | Must this unfolding happen for the code to be executable? -- | Must this unfolding happen for the code to be executable?
isCompulsoryUnfolding :: Unfolding -> Bool isCompulsoryUnfolding :: Unfolding -> Bool
...@@ -509,9 +515,9 @@ isCompulsoryUnfolding _ = False ...@@ -509,9 +515,9 @@ isCompulsoryUnfolding _ = False
-- | Do we have an available or compulsory unfolding? -- | Do we have an available or compulsory unfolding?
hasUnfolding :: Unfolding -> Bool hasUnfolding :: Unfolding -> Bool
hasUnfolding (CoreUnfolding _ _ _ _ _) = True hasUnfolding (CoreUnfolding _ _ _ _ _ _) = True
hasUnfolding (CompulsoryUnfolding _) = True hasUnfolding (CompulsoryUnfolding _) = True
hasUnfolding _ = False hasUnfolding _ = False
-- | Only returns False if there is no unfolding information available at all -- | Only returns False if there is no unfolding information available at all
hasSomeUnfolding :: Unfolding -> Bool hasSomeUnfolding :: Unfolding -> Bool
...@@ -521,10 +527,10 @@ hasSomeUnfolding _ = True ...@@ -521,10 +527,10 @@ hasSomeUnfolding _ = True
-- | Similar to @not . hasUnfolding@, but also returns @True@ -- | Similar to @not . hasUnfolding@, but also returns @True@
-- if it has an unfolding that says it should never occur -- if it has an unfolding that says it should never occur
neverUnfold :: Unfolding -> Bool neverUnfold :: Unfolding -> Bool
neverUnfold NoUnfolding = True neverUnfold NoUnfolding = True
neverUnfold (OtherCon _) = True neverUnfold (OtherCon _) = True
neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True neverUnfold (CoreUnfolding _ _ _ _ _ UnfoldNever) = True
neverUnfold _ = False neverUnfold _ = False
\end{code} \end{code}
......
...@@ -22,7 +22,7 @@ module CoreUnfold ( ...@@ -22,7 +22,7 @@ module CoreUnfold (
mkCompulsoryUnfolding, seqUnfolding, mkCompulsoryUnfolding, seqUnfolding,
evaldUnfolding, mkOtherCon, otherCons, evaldUnfolding, mkOtherCon, otherCons,
unfoldingTemplate, maybeUnfoldingTemplate, unfoldingTemplate, maybeUnfoldingTemplate,
isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding, isEvaldUnfolding, isValueUnfolding, isExpandableUnfolding, isCompulsoryUnfolding,
hasUnfolding, hasSomeUnfolding, neverUnfold, hasUnfolding, hasSomeUnfolding, neverUnfold,
couldBeSmallEnoughToInline, couldBeSmallEnoughToInline,
...@@ -71,7 +71,8 @@ mkImplicitUnfolding expr ...@@ -71,7 +71,8 @@ mkImplicitUnfolding expr
= CoreUnfolding (simpleOptExpr emptySubst expr) = CoreUnfolding (simpleOptExpr emptySubst expr)
True True
(exprIsHNF expr) (exprIsHNF expr)
(exprIsCheap expr) (exprIsCheap expr)
(exprIsExpandable expr)
(calcUnfoldingGuidance opt_UF_CreationThreshold expr) (calcUnfoldingGuidance opt_UF_CreationThreshold expr)
mkUnfolding :: Bool -> CoreExpr -> Unfolding mkUnfolding :: Bool -> CoreExpr -> Unfolding
...@@ -85,6 +86,8 @@ mkUnfolding top_lvl expr ...@@ -85,6 +86,8 @@ mkUnfolding top_lvl expr
(exprIsCheap expr) (exprIsCheap expr)
-- OK to inline inside a lambda -- OK to inline inside a lambda
(exprIsExpandable expr)
(calcUnfoldingGuidance opt_UF_CreationThreshold expr) (calcUnfoldingGuidance opt_UF_CreationThreshold expr)
-- Sometimes during simplification, there's a large let-bound thing -- Sometimes during simplification, there's a large let-bound thing
-- which has been substituted, and so is now dead; so 'expr' contains -- which has been substituted, and so is now dead; so 'expr' contains
...@@ -99,8 +102,8 @@ instance Outputable Unfolding where ...@@ -99,8 +102,8 @@ instance Outputable Unfolding where
ppr NoUnfolding = ptext (sLit "No unfolding") ppr NoUnfolding = ptext (sLit "No unfolding")
ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs
ppr (CompulsoryUnfolding e) = ptext (sLit "Compulsory") <+> ppr e ppr (CompulsoryUnfolding e) = ptext (sLit "Compulsory") <+> ppr e
ppr (CoreUnfolding e top hnf cheap g) ppr (CoreUnfolding e top hnf cheap expable g)
= ptext (sLit "Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr g, = ptext (sLit "Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr expable <+> ppr g,
ppr e] ppr e]
mkCompulsoryUnfolding :: CoreExpr -> Unfolding mkCompulsoryUnfolding :: CoreExpr -> Unfolding
...@@ -484,13 +487,13 @@ couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold ...@@ -484,13 +487,13 @@ couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold
certainlyWillInline :: Unfolding -> Bool certainlyWillInline :: Unfolding -> Bool
-- Sees if the unfolding is pretty certain to inline -- Sees if the unfolding is pretty certain to inline
certainlyWillInline (CoreUnfolding _ _ _ is_cheap (UnfoldIfGoodArgs n_vals _ size _)) certainlyWillInline (CoreUnfolding _ _ _ is_cheap _ (UnfoldIfGoodArgs n_vals _ size _))
= is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold = is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold
certainlyWillInline _ certainlyWillInline _
= False = False
smallEnoughToInline :: Unfolding -> Bool smallEnoughToInline :: Unfolding -> Bool
smallEnoughToInline (CoreUnfolding _ _ _ _ (UnfoldIfGoodArgs _ _ size _)) smallEnoughToInline (CoreUnfolding _ _ _ _ _ (UnfoldIfGoodArgs _ _ size _))
= size <= opt_UF_UseThreshold = size <= opt_UF_UseThreshold
smallEnoughToInline _ smallEnoughToInline _
= False = False
...@@ -561,7 +564,7 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info ...@@ -561,7 +564,7 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
-- compulsory unfoldings (see MkId.lhs). -- compulsory unfoldings (see MkId.lhs).
-- We don't allow them to be inactive -- We don't allow them to be inactive
CoreUnfolding unf_template is_top is_value is_cheap guidance -> CoreUnfolding unf_template is_top is_value is_cheap is_expable guidance ->
let let
result | yes_or_no = Just unf_template result | yes_or_no = Just unf_template
...@@ -639,7 +642,8 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info ...@@ -639,7 +642,8 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
text "arg infos" <+> ppr arg_infos, text "arg infos" <+> ppr arg_infos,
text "interesting continuation" <+> ppr cont_info, text "interesting continuation" <+> ppr cont_info,
text "is value:" <+> ppr is_value, text "is value:" <+> ppr is_value,
text "is cheap:" <+> ppr is_cheap, text "is cheap:" <+> ppr is_cheap,
text "is expandable:" <+> ppr is_expable,
text "guidance" <+> ppr guidance, text "guidance" <+> ppr guidance,
text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"]) text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"])
result result
......
...@@ -25,7 +25,7 @@ module CoreUtils ( ...@@ -25,7 +25,7 @@ module CoreUtils (
-- * Properties of expressions -- * Properties of expressions
exprType, coreAltType, coreAltsType, exprType, coreAltType, coreAltsType,
exprIsDupable, exprIsTrivial, exprIsCheap, exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable,
exprIsHNF,exprOkForSpeculation, exprIsBig, exprIsHNF,exprOkForSpeculation, exprIsBig,
exprIsConApp_maybe, exprIsBottom, exprIsConApp_maybe, exprIsBottom,
rhsIsStatic, rhsIsStatic,
...@@ -37,7 +37,7 @@ module CoreUtils ( ...@@ -37,7 +37,7 @@ module CoreUtils (
hashExpr, hashExpr,
-- * Equality -- * Equality
cheapEqExpr, tcEqExpr, tcEqExprX, cheapEqExpr,
-- * Manipulating data constructors and types -- * Manipulating data constructors and types
applyTypeToArgs, applyTypeToArg, applyTypeToArgs, applyTypeToArg,
...@@ -47,11 +47,9 @@ module CoreUtils ( ...@@ -47,11 +47,9 @@ module CoreUtils (
#include "HsVersions.h" #include "HsVersions.h"
import CoreSyn import CoreSyn
import CoreFVs
import PprCore import PprCore
import Var import Var
import SrcLoc import SrcLoc
import VarSet
import VarEnv import VarEnv
import Name import Name
import Module import Module
...@@ -462,27 +460,28 @@ Notice that a variable is considered 'cheap': we can push it inside a lambda, ...@@ -462,27 +460,28 @@ Notice that a variable is considered 'cheap': we can push it inside a lambda,
because sharing will make sure it is only evaluated once. because sharing will make sure it is only evaluated once.
\begin{code} \begin{code}
exprIsCheap :: CoreExpr -> Bool exprIsCheap' :: (Id -> Bool) -> CoreExpr -> Bool
exprIsCheap (Lit _) = True exprIsCheap' _ (Lit _) = True
exprIsCheap (Type _) = True exprIsCheap' _ (Type _) = True
exprIsCheap (Var _) = True exprIsCheap' _ (Var _) = True
exprIsCheap (Note InlineMe _) = True exprIsCheap' _ (Note InlineMe _) = True
exprIsCheap (Note _ e) = exprIsCheap e exprIsCheap' is_conlike (Note _ e) = exprIsCheap' is_conlike e
exprIsCheap (Cast e _) = exprIsCheap e exprIsCheap' is_conlike (Cast e _) = exprIsCheap' is_conlike e
exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e exprIsCheap' is_conlike (Lam x e) = isRuntimeVar x
exprIsCheap (Case e _ _ alts) = exprIsCheap e && || exprIsCheap' is_conlike e
and [exprIsCheap rhs | (_,_,rhs) <- alts] exprIsCheap' is_conlike (Case e _ _ alts) = exprIsCheap' is_conlike e &&
and [exprIsCheap' is_conlike rhs | (_,_,rhs) <- alts]
-- Experimentally, treat (case x of ...) as cheap -- Experimentally, treat (case x of ...) as cheap
-- (and case __coerce x etc.) -- (and case __coerce x etc.)
-- This improves arities of overloaded functions where -- This improves arities of overloaded functions where
-- there is only dictionary selection (no construction) involved -- there is only dictionary selection (no construction) involved
exprIsCheap (Let (NonRec x _) e) exprIsCheap' is_conlike (Let (NonRec x _) e)
| isUnLiftedType (idType x) = exprIsCheap e | isUnLiftedType (idType x) = exprIsCheap' is_conlike e
| otherwise = False | otherwise = False
-- strict lets always have cheap right hand sides, -- strict lets always have cheap right hand sides,
-- and do no allocation. -- and do no allocation.
exprIsCheap other_expr -- Applications and variables exprIsCheap' is_conlike other_expr -- Applications and variables
= go other_expr [] = go other_expr []
where where
-- Accumulate value arguments, then decide -- Accumulate value arguments, then decide
...@@ -497,8 +496,8 @@ exprIsCheap other_expr -- Applications and variables ...@@ -497,8 +496,8 @@ exprIsCheap other_expr -- Applications and variables
ClassOpId _ -> go_sel args ClassOpId _ -> go_sel args
PrimOpId op -> go_primop op args PrimOpId op -> go_primop op args
DataConWorkId _ -> go_pap args _ | is_conlike f -> go_pap args
_ | length args < idArity f -> go_pap args | length args < idArity f -> go_pap args
_ -> isBottomingId f _ -> isBottomingId f
-- Application of a function which -- Application of a function which
...@@ -515,18 +514,24 @@ exprIsCheap other_expr -- Applications and variables ...@@ -515,18 +514,24 @@ exprIsCheap other_expr -- Applications and variables
-- We'll put up with one constructor application, but not dozens -- We'll put up with one constructor application, but not dozens
-------------- --------------
go_primop op args = primOpIsCheap op && all exprIsCheap args go_primop op args = primOpIsCheap op && all (exprIsCheap' is_conlike) args
-- In principle we should worry about primops -- In principle we should worry about primops
-- that return a type variable, since the result -- that return a type variable, since the result
-- might be applied to something, but I'm not going -- might be applied to something, but I'm not going
-- to bother to check the number of args -- to bother to check the number of args
-------------- --------------
go_sel [arg] = exprIsCheap arg -- I'm experimenting with making record selection go_sel [arg] = exprIsCheap' is_conlike arg -- I'm experimenting with making record selection
go_sel _ = False -- look cheap, so we will substitute it inside a go_sel _ = False -- look cheap, so we will substitute it inside a
-- lambda. Particularly for dictionary field selection. -- lambda. Particularly for dictionary field selection.
-- BUT: Take care with (sel d x)! The (sel d) might be cheap, but -- BUT: Take care with (sel d x)! The (sel d) might be cheap, but
-- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1) -- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)
exprIsCheap :: CoreExpr -> Bool
exprIsCheap = exprIsCheap' isDataConWorkId
exprIsExpandable :: CoreExpr -> Bool
exprIsExpandable = exprIsCheap' isConLikeId
\end{code} \end{code}
\begin{code} \begin{code}
...@@ -899,7 +904,7 @@ exprIsConApp_maybe expr = analyse (collectArgs expr) ...@@ -899,7 +904,7 @@ exprIsConApp_maybe expr = analyse (collectArgs expr)
-- we are effectively duplicating the unfolding -- we are effectively duplicating the unfolding