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(
CompilerPhase,
Activation(..), isActive, isNeverActive, isAlwaysActive,
RuleMatchInfo(..), isConLike, isFunLike,
InlinePragma(..), defaultInlinePragma, isDefaultInlinePragma,
inlinePragmaActivation, inlinePragmaRuleMatchInfo,
setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
InlineSpec(..), defaultInlineSpec, alwaysInlineSpec, neverInlineSpec,
SuccessFlag(..), succeeded, failed, successIf
......@@ -580,35 +584,94 @@ data Activation = NeverActive
| ActiveAfter CompilerPhase -- Active in this phase and later
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
= Inline
Activation -- Says during which phases inlining is allowed
= Inline
InlinePragma
Bool -- True <=> INLINE
-- False <=> NOINLINE
deriving( Eq )
defaultInlineSpec, alwaysInlineSpec, neverInlineSpec :: InlineSpec
defaultInlineSpec :: InlineSpec
alwaysInlineSpec, neverInlineSpec :: RuleMatchInfo -> InlineSpec
defaultInlineSpec = Inline AlwaysActive False -- Inlining is OK, but not forced
alwaysInlineSpec = Inline AlwaysActive True -- INLINE always
neverInlineSpec = Inline NeverActive False -- NOINLINE
defaultInlineSpec = Inline defaultInlinePragma False
-- Inlining is OK, but not forced
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
ppr NeverActive = ptext (sLit "NEVER")
ppr AlwaysActive = ptext (sLit "ALWAYS")
ppr (ActiveBefore n) = brackets (char '~' <> 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
ppr (Inline act is_inline)
ppr (Inline (InlinePragma act match_info) is_inline)
| is_inline = ptext (sLit "INLINE")
<> case act of
AlwaysActive -> empty
_ -> ppr act
<+> ppr_match_info
<+> case act of
AlwaysActive -> empty
_ -> ppr act
| otherwise = ptext (sLit "NOINLINE")
<> case act of
NeverActive -> empty
_ -> ppr act
<+> ppr_match_info
<+> case act of
NeverActive -> empty
_ -> ppr act
where
ppr_match_info = if isFunLike match_info then empty else ppr match_info
isActive :: CompilerPhase -> Activation -> Bool
isActive _ NeverActive = False
......
......@@ -53,12 +53,13 @@ module Id (
isPrimOpId, isPrimOpId_maybe,
isFCallId, isFCallId_maybe,
isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,
isBottomingId, idIsFrom,
isConLikeId, isBottomingId, idIsFrom,
isTickBoxOp, isTickBoxOp_maybe,
hasNoBinding,
-- ** Inline pragma stuff
idInlinePragma, setInlinePragma, modifyInlinePragma,
idInlinePragma, setInlinePragma, modifyInlinePragma,
idInlineActivation, setInlineActivation, idRuleMatchInfo,
-- ** One-shot lambdas
isOneShotBndr, isOneShotLambda, isStateHackType,
......@@ -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.
\begin{code}
idInlinePragma :: Id -> InlinePragInfo
idInlinePragma :: Id -> InlinePragma
idInlinePragma id = inlinePragInfo (idInfo id)
setInlinePragma :: Id -> InlinePragInfo -> Id
setInlinePragma :: Id -> InlinePragma -> 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
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}
......
......@@ -329,7 +329,7 @@ data IdInfo
unfoldingInfo :: Unfolding, -- ^ The 'Id's unfolding
cafInfo :: CafInfo, -- ^ 'Id' CAF info
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
newStrictnessInfo :: Maybe StrictSig, -- ^ Id strictness information. Reason for Maybe:
......@@ -378,7 +378,7 @@ setWorkerInfo :: IdInfo -> WorkerInfo -> IdInfo
setWorkerInfo info wk = wk `seq` info { workerInfo = wk }
setSpecInfo :: IdInfo -> SpecInfo -> IdInfo
setSpecInfo info sp = sp `seq` info { specInfo = sp }
setInlinePragInfo :: IdInfo -> InlinePragInfo -> IdInfo
setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo
setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr }
setOccInfo :: IdInfo -> OccInfo -> IdInfo
setOccInfo info oc = oc `seq` info { occInfo = oc }
......@@ -434,7 +434,7 @@ vanillaIdInfo
workerInfo = NoWorker,
unfoldingInfo = noUnfolding,
lbvarInfo = NoLBVarInfo,
inlinePragInfo = AlwaysActive,
inlinePragInfo = defaultInlinePragma,
occInfo = NoOccInfo,
newDemandInfo = Nothing,
newStrictnessInfo = Nothing
......@@ -493,7 +493,7 @@ ppArityInfo n = hsep [ptext (sLit "Arity"), int n]
--
-- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves
-- entirely as a way to inhibit inlining until we want it
type InlinePragInfo = Activation
type InlinePragInfo = InlinePragma
\end{code}
......
......@@ -42,7 +42,8 @@ module CoreSyn (
-- ** Predicates and deconstruction on 'Unfolding'
unfoldingTemplate, maybeUnfoldingTemplate, otherCons,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
isExpandableUnfolding, isCompulsoryUnfolding,
hasUnfolding, hasSomeUnfolding, neverUnfold,
-- * Strictness
......@@ -412,6 +413,7 @@ data Unfolding
Bool
Bool
Bool
Bool
UnfoldingGuidance
-- ^ An unfolding with redundant cached information. Parameters:
--
......@@ -455,8 +457,8 @@ mkOtherCon :: [AltCon] -> Unfolding
mkOtherCon = OtherCon
seqUnfolding :: Unfolding -> ()
seqUnfolding (CoreUnfolding e top b1 b2 g)
= seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
seqUnfolding (CoreUnfolding e top b1 b2 b3 g)
= seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` seqGuidance g
seqUnfolding _ = ()
seqGuidance :: UnfoldingGuidance -> ()
......@@ -467,15 +469,15 @@ seqGuidance _ = ()
\begin{code}
-- | Retrieves the template of an unfolding: panics if none is known
unfoldingTemplate :: Unfolding -> CoreExpr
unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
unfoldingTemplate (CompulsoryUnfolding expr) = expr
unfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = expr
unfoldingTemplate (CompulsoryUnfolding expr) = expr
unfoldingTemplate _ = panic "getUnfoldingTemplate"
-- | Retrieves the template of an unfolding if possible
maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
maybeUnfoldingTemplate _ = Nothing
maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = Just expr
maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
maybeUnfoldingTemplate _ = Nothing
-- | The constructors that the unfolding could never be:
-- returns @[]@ if no information is available
......@@ -486,21 +488,25 @@ otherCons _ = []
-- | Determines if it is certainly the case that the unfolding will
-- yield a value (something in HNF): returns @False@ if unsure
isValueUnfolding :: Unfolding -> Bool
isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
isValueUnfolding _ = False
isValueUnfolding (CoreUnfolding _ _ is_evald _ _ _) = is_evald
isValueUnfolding _ = False
-- | Determines if it possibly the case that the unfolding will
-- yield a value. Unlike 'isValueUnfolding' it returns @True@
-- for 'OtherCon'
isEvaldUnfolding :: Unfolding -> Bool
isEvaldUnfolding (OtherCon _) = True
isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
isEvaldUnfolding _ = False
isEvaldUnfolding (OtherCon _) = True
isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _ _) = is_evald
isEvaldUnfolding _ = False
-- | Is the thing we will unfold into certainly cheap?
isCheapUnfolding :: Unfolding -> Bool
isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
isCheapUnfolding _ = False
isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _ _) = is_cheap
isCheapUnfolding _ = False
isExpandableUnfolding :: Unfolding -> Bool
isExpandableUnfolding (CoreUnfolding _ _ _ _ is_expable _) = is_expable
isExpandableUnfolding _ = False
-- | Must this unfolding happen for the code to be executable?
isCompulsoryUnfolding :: Unfolding -> Bool
......@@ -509,9 +515,9 @@ isCompulsoryUnfolding _ = False
-- | Do we have an available or compulsory unfolding?
hasUnfolding :: Unfolding -> Bool
hasUnfolding (CoreUnfolding _ _ _ _ _) = True
hasUnfolding (CompulsoryUnfolding _) = True
hasUnfolding _ = False
hasUnfolding (CoreUnfolding _ _ _ _ _ _) = True
hasUnfolding (CompulsoryUnfolding _) = True
hasUnfolding _ = False
-- | Only returns False if there is no unfolding information available at all
hasSomeUnfolding :: Unfolding -> Bool
......@@ -521,10 +527,10 @@ hasSomeUnfolding _ = True
-- | Similar to @not . hasUnfolding@, but also returns @True@
-- if it has an unfolding that says it should never occur
neverUnfold :: Unfolding -> Bool
neverUnfold NoUnfolding = True
neverUnfold (OtherCon _) = True
neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
neverUnfold _ = False
neverUnfold NoUnfolding = True
neverUnfold (OtherCon _) = True
neverUnfold (CoreUnfolding _ _ _ _ _ UnfoldNever) = True
neverUnfold _ = False
\end{code}
......
......@@ -22,7 +22,7 @@ module CoreUnfold (
mkCompulsoryUnfolding, seqUnfolding,
evaldUnfolding, mkOtherCon, otherCons,
unfoldingTemplate, maybeUnfoldingTemplate,
isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
isEvaldUnfolding, isValueUnfolding, isExpandableUnfolding, isCompulsoryUnfolding,
hasUnfolding, hasSomeUnfolding, neverUnfold,
couldBeSmallEnoughToInline,
......@@ -71,7 +71,8 @@ mkImplicitUnfolding expr
= CoreUnfolding (simpleOptExpr emptySubst expr)
True
(exprIsHNF expr)
(exprIsCheap expr)
(exprIsCheap expr)
(exprIsExpandable expr)
(calcUnfoldingGuidance opt_UF_CreationThreshold expr)
mkUnfolding :: Bool -> CoreExpr -> Unfolding
......@@ -85,6 +86,8 @@ mkUnfolding top_lvl expr
(exprIsCheap expr)
-- OK to inline inside a lambda
(exprIsExpandable expr)
(calcUnfoldingGuidance 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
......@@ -99,8 +102,8 @@ instance Outputable Unfolding where
ppr NoUnfolding = ptext (sLit "No unfolding")
ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs
ppr (CompulsoryUnfolding e) = ptext (sLit "Compulsory") <+> ppr e
ppr (CoreUnfolding e top hnf cheap g)
= ptext (sLit "Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr g,
ppr (CoreUnfolding e top hnf cheap expable g)
= ptext (sLit "Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr expable <+> ppr g,
ppr e]
mkCompulsoryUnfolding :: CoreExpr -> Unfolding
......@@ -484,13 +487,13 @@ couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold
certainlyWillInline :: Unfolding -> Bool
-- 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
certainlyWillInline _
= False
smallEnoughToInline :: Unfolding -> Bool
smallEnoughToInline (CoreUnfolding _ _ _ _ (UnfoldIfGoodArgs _ _ size _))
smallEnoughToInline (CoreUnfolding _ _ _ _ _ (UnfoldIfGoodArgs _ _ size _))
= size <= opt_UF_UseThreshold
smallEnoughToInline _
= False
......@@ -561,7 +564,7 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
-- compulsory unfoldings (see MkId.lhs).
-- 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
result | yes_or_no = Just unf_template
......@@ -639,7 +642,8 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
text "arg infos" <+> ppr arg_infos,
text "interesting continuation" <+> ppr cont_info,
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 "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"])
result
......
......@@ -25,7 +25,7 @@ module CoreUtils (
-- * Properties of expressions
exprType, coreAltType, coreAltsType,
exprIsDupable, exprIsTrivial, exprIsCheap,
exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable,
exprIsHNF,exprOkForSpeculation, exprIsBig,
exprIsConApp_maybe, exprIsBottom,
rhsIsStatic,
......@@ -37,7 +37,7 @@ module CoreUtils (
hashExpr,
-- * Equality
cheapEqExpr, tcEqExpr, tcEqExprX,
cheapEqExpr,
-- * Manipulating data constructors and types
applyTypeToArgs, applyTypeToArg,
......@@ -47,11 +47,9 @@ module CoreUtils (
#include "HsVersions.h"
import CoreSyn
import CoreFVs
import PprCore
import Var
import SrcLoc
import VarSet
import VarEnv
import Name
import Module
......@@ -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.
\begin{code}
exprIsCheap :: CoreExpr -> Bool
exprIsCheap (Lit _) = True
exprIsCheap (Type _) = True
exprIsCheap (Var _) = True
exprIsCheap (Note InlineMe _) = True
exprIsCheap (Note _ e) = exprIsCheap e
exprIsCheap (Cast e _) = exprIsCheap e
exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
and [exprIsCheap rhs | (_,_,rhs) <- alts]
exprIsCheap' :: (Id -> Bool) -> CoreExpr -> Bool
exprIsCheap' _ (Lit _) = True
exprIsCheap' _ (Type _) = True
exprIsCheap' _ (Var _) = True
exprIsCheap' _ (Note InlineMe _) = True
exprIsCheap' is_conlike (Note _ e) = exprIsCheap' is_conlike e
exprIsCheap' is_conlike (Cast e _) = exprIsCheap' is_conlike e
exprIsCheap' is_conlike (Lam x e) = isRuntimeVar x
|| exprIsCheap' is_conlike e
exprIsCheap' is_conlike (Case e _ _ alts) = exprIsCheap' is_conlike e &&
and [exprIsCheap' is_conlike rhs | (_,_,rhs) <- alts]
-- Experimentally, treat (case x of ...) as cheap
-- (and case __coerce x etc.)
-- This improves arities of overloaded functions where
-- there is only dictionary selection (no construction) involved
exprIsCheap (Let (NonRec x _) e)
| isUnLiftedType (idType x) = exprIsCheap e
exprIsCheap' is_conlike (Let (NonRec x _) e)
| isUnLiftedType (idType x) = exprIsCheap' is_conlike e
| otherwise = False
-- strict lets always have cheap right hand sides,
-- and do no allocation.
exprIsCheap other_expr -- Applications and variables
exprIsCheap' is_conlike other_expr -- Applications and variables
= go other_expr []
where
-- Accumulate value arguments, then decide
......@@ -497,8 +496,8 @@ exprIsCheap other_expr -- Applications and variables
ClassOpId _ -> go_sel args
PrimOpId op -> go_primop op args
DataConWorkId _ -> go_pap args
_ | length args < idArity f -> go_pap args
_ | is_conlike f -> go_pap args
| length args < idArity f -> go_pap args
_ -> isBottomingId f
-- Application of a function which
......@@ -515,18 +514,24 @@ exprIsCheap other_expr -- Applications and variables
-- 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
-- that return a type variable, since the result
-- might be applied to something, but I'm not going
-- 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
-- lambda. Particularly for dictionary field selection.
-- 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)
exprIsCheap :: CoreExpr -> Bool
exprIsCheap = exprIsCheap' isDataConWorkId
exprIsExpandable :: CoreExpr -> Bool
exprIsExpandable = exprIsCheap' isConLikeId
\end{code}
\begin{code}
......@@ -899,7 +904,7 @@ exprIsConApp_maybe expr = analyse (collectArgs expr)
-- we are effectively duplicating the unfolding
analyse (Var fun, [])
| let unf = idUnfolding fun,
isCheapUnfolding unf
isExpandableUnfolding unf
= exprIsConApp_maybe (unfoldingTemplate unf)
analyse _ = Nothing
......@@ -944,53 +949,6 @@ exprIsBig _ = True
\end{code}
\begin{code}
tcEqExpr :: CoreExpr -> CoreExpr -> Bool
-- ^ A kind of shallow equality used in rule matching, so does
-- /not/ look through newtypes or predicate types
tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2
where
rn_env = mkRnEnv2 (mkInScopeSet (exprFreeVars e1 `unionVarSet` exprFreeVars e2))
tcEqExprX :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
tcEqExprX env (Var v1) (Var v2) = rnOccL env v1 == rnOccR env v2
tcEqExprX _ (Lit lit1) (Lit lit2) = lit1 == lit2
tcEqExprX env (App f1 a1) (App f2 a2) = tcEqExprX env f1 f2 && tcEqExprX env a1 a2
tcEqExprX env (Lam v1 e1) (Lam v2 e2) = tcEqExprX (rnBndr2 env v1 v2) e1 e2
tcEqExprX env (Let (NonRec v1 r1) e1)
(Let (NonRec v2 r2) e2) = tcEqExprX env r1 r2
&& tcEqExprX (rnBndr2 env v1 v2) e1 e2
tcEqExprX env (Let (Rec ps1) e1)
(Let (Rec ps2) e2) = equalLength ps1 ps2
&& and (zipWith eq_rhs ps1 ps2)
&& tcEqExprX env' e1 e2
where
env' = foldl2 rn_bndr2 env ps2 ps2
rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
eq_rhs (_,r1) (_,r2) = tcEqExprX env' r1 r2
tcEqExprX env (Case e1 v1 t1 a1)
(Case e2 v2 t2 a2) = tcEqExprX env e1 e2
&& tcEqTypeX env t1 t2
&& equalLength a1 a2
&& and (zipWith (eq_alt env') a1 a2)
where
env' = rnBndr2 env v1 v2
tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2
tcEqExprX env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && tcEqExprX env e1 e2
tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2
tcEqExprX _ _ _ = False
eq_alt :: RnEnv2 -> CoreAlt -> CoreAlt -> Bool
eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && tcEqExprX (rnBndrs2 env vs1 vs2) r1 r2
eq_note :: RnEnv2 -> Note -> Note -> Bool
eq_note _ (SCC cc1) (SCC cc2) = cc1 == cc2
eq_note _ (CoreNote s1) (CoreNote s2) = s1 == s2
eq_note _ _ _ = False
\end{code}
%************************************************************************
%* *
......
......@@ -310,7 +310,7 @@ pprIdBndrInfo info
dmd_info = newDemandInfo info
lbv_info = lbvarInfo info
no_info = isAlwaysActive prag_info && isNoOcc occ_info &&
no_info = isDefaultInlinePragma prag_info && isNoOcc occ_info &&
(case dmd_info of { Nothing -> True; Just d -> isTop d }) &&
hasNoLBVarInfo lbv_info
......
......@@ -516,12 +516,12 @@ addInlinePrags prags bndr rhs
(inl:_) -> addInlineInfo inl bndr rhs
addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
addInlineInfo (Inline phase is_inline) bndr rhs
= (attach_phase bndr phase, wrap_inline is_inline rhs)
addInlineInfo (Inline prag is_inline) bndr rhs
= (attach_pragma bndr prag, wrap_inline is_inline rhs)
where
attach_phase bndr phase
| isAlwaysActive phase = bndr -- Default phase
| otherwise = bndr `setInlinePragma` phase
attach_pragma bndr prag
| isDefaultInlinePragma prag = bndr
| otherwise = bndr `setInlinePragma` prag
wrap_inline True body = mkInlineMe body
wrap_inline False body = body
......
......@@ -387,7 +387,7 @@ dsFExportDynamic id cconv = do
, Lam stbl_value ccall_adj
]
fed = (id `setInlinePragma` NeverActive, io_app)
fed = (id `setInlineActivation` NeverActive, io_app)
-- Never inline the f.e.d. function, because the litlit
-- might not be in scope in other modules.
......
......@@ -578,6 +578,24 @@ instance Binary Activation where
_ -> do ab <- get bh
return (ActiveAfter ab)
instance Binary RuleMatchInfo where
put_ bh FunLike = putByte bh 0
put_ bh ConLike = putByte bh 1
get bh = do
h <- getByte bh
if h == 1 then return ConLike
else return FunLike
instance Binary InlinePragma where
put_ bh (InlinePragma activation match_info) = do
put_ bh activation
put_ bh match_info
get bh = do
act <- get bh
info <- get bh
return (InlinePragma act info)
instance Binary StrictnessMark where
put_ bh MarkedStrict = putByte bh 0
put_ bh MarkedUnboxed = putByte bh 1
......
......@@ -203,7 +203,7 @@ data IfaceIdInfo
data IfaceInfoItem
= HsArity Arity
| HsStrictness StrictSig
| HsInline Activation
| HsInline InlinePragma
| HsUnfold IfaceExpr
| HsNoCafRefs
| HsWorker Name Arity -- Worker, if any see IdInfo.WorkerInfo
......@@ -660,7 +660,7 @@ instance Outputable IfaceIdInfo where
instance Outputable IfaceInfoItem where
ppr (HsUnfold unf) = ptext (sLit "Unfolding:") <+>
parens (pprIfaceExpr noParens unf)
ppr (HsInline act) = ptext (sLit "Inline:") <+> ppr act
ppr (HsInline prag) = ptext (sLit "Inline:") <+> ppr prag
ppr (HsArity arity) = ptext (sLit "Arity:") <+> int arity
ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str
ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs")
......
......@@ -1440,8 +1440,8 @@ toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
-- See Note [IdInfo on nested let-bindings] in IfaceSyn
id_info = idInfo id
inline_prag = inlinePragInfo id_info
prag_info | isAlwaysActive inline_prag = NoInfo
| otherwise = HasInfo [HsInline inline_prag]
prag_info | isDefaultInlinePragma inline_prag = NoInfo
| otherwise = HasInfo [HsInline inline_prag]
--------------------------
toIfaceIdDetails :: IdDetails -> IfaceIdDetails
......@@ -1495,11 +1495,13 @@ toIfaceIdInfo id_info
------------ Inline prag --------------
inline_prag = inlinePragInfo id_info
inline_hsinfo | isAlwaysActive inline_prag = Nothing
| no_unfolding && not has_worker = Nothing
inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
| no_unfolding && not has_worker
&& isFunLike (inlinePragmaRuleMatchInfo inline_prag)
= Nothing
-- If the iface file give no unfolding info, we
-- don't need to say when inlining is OK!
| otherwise = Just (HsInline inline_prag)
| otherwise = Just (HsInline inline_prag)
--------------------------
coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule
......
......@@ -561,7 +561,7 @@ addExternal (id,rhs) needed
spec_ids
idinfo = idInfo id
dont_inline = isNeverActive (inlinePragInfo idinfo)
dont_inline = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))