CompilerPhase,
Activation(..), isActive, isNeverActive, isAlwaysActive,
+ RuleMatchInfo(..), isConLike, isFunLike,
+ InlinePragma(..), defaultInlinePragma, isDefaultInlinePragma,
+ inlinePragmaActivation, inlinePragmaRuleMatchInfo,
+ setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
InlineSpec(..), defaultInlineSpec, alwaysInlineSpec, neverInlineSpec,
SuccessFlag(..), succeeded, failed, successIf
| 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
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,
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}
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:
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 }
workerInfo = NoWorker,
unfoldingInfo = noUnfolding,
lbvarInfo = NoLBVarInfo,
- inlinePragInfo = AlwaysActive,
+ inlinePragInfo = defaultInlinePragma,
occInfo = NoOccInfo,
newDemandInfo = Nothing,
newStrictnessInfo = Nothing
--
-- 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}
-- ** Predicates and deconstruction on 'Unfolding'
unfoldingTemplate, maybeUnfoldingTemplate, otherCons,
- isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
+ isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
+ isExpandableUnfolding, isCompulsoryUnfolding,
hasUnfolding, hasSomeUnfolding, neverUnfold,
-- * Strictness
Bool
Bool
Bool
+ Bool
UnfoldingGuidance
-- ^ An unfolding with redundant cached information. Parameters:
--
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 -> ()
\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
-- | 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
-- | 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
-- | 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}
mkCompulsoryUnfolding, seqUnfolding,
evaldUnfolding, mkOtherCon, otherCons,
unfoldingTemplate, maybeUnfoldingTemplate,
- isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
+ isEvaldUnfolding, isValueUnfolding, isExpandableUnfolding, isCompulsoryUnfolding,
hasUnfolding, hasSomeUnfolding, neverUnfold,
couldBeSmallEnoughToInline,
= CoreUnfolding (simpleOptExpr emptySubst expr)
True
(exprIsHNF expr)
- (exprIsCheap expr)
+ (exprIsCheap expr)
+ (exprIsExpandable expr)
(calcUnfoldingGuidance opt_UF_CreationThreshold expr)
mkUnfolding :: Bool -> CoreExpr -> Unfolding
(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
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
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
-- 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
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
-- * Properties of expressions
exprType, coreAltType, coreAltsType,
- exprIsDupable, exprIsTrivial, exprIsCheap,
+ exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable,
exprIsHNF,exprOkForSpeculation, exprIsBig,
exprIsConApp_maybe, exprIsBottom,
rhsIsStatic,
hashExpr,
-- * Equality
- cheapEqExpr, tcEqExpr, tcEqExprX,
+ cheapEqExpr,
-- * Manipulating data constructors and types
applyTypeToArgs, applyTypeToArg,
#include "HsVersions.h"
import CoreSyn
-import CoreFVs
import PprCore
import Var
import SrcLoc
-import VarSet
import VarEnv
import Name
import Module
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
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
-- 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}
-- we are effectively duplicating the unfolding
analyse (Var fun, [])
| let unf = idUnfolding fun,
- isCheapUnfolding unf
+ isExpandableUnfolding unf
= exprIsConApp_maybe (unfoldingTemplate unf)
analyse _ = Nothing
\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}
-
%************************************************************************
%* *
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
(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
, 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.
_ -> 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
data IfaceInfoItem
= HsArity Arity
| HsStrictness StrictSig
- | HsInline Activation
+ | HsInline InlinePragma
| HsUnfold IfaceExpr
| HsNoCafRefs
| HsWorker Name Arity -- Worker, if any see IdInfo.WorkerInfo
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")
-- 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
------------ 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
spec_ids
idinfo = idInfo id
- dont_inline = isNeverActive (inlinePragInfo idinfo)
+ dont_inline = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))
loop_breaker = isNonRuleLoopBreaker (occInfo idinfo)
bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
spec_ids = specInfoFreeVars (specInfo idinfo)
{ token (ITinline_prag True) }
"{-#" $whitechar* (NO(T?)INLINE|no(t?)inline) / { notFollowedByPragmaChar }
{ token (ITinline_prag False) }
+ "{-#" $whitechar* (INLINE|inline)
+ $whitechar+ (CONLIKE|conlike) / { notFollowedByPragmaChar }
+ { token (ITinline_conlike_prag True) }
+ "{-#" $whitechar* (NO(T)?INLINE|no(t?)inline)
+ $whitechar+ (CONLIKE|constructorlike) / { notFollowedByPragmaChar }
+ { token (ITinline_conlike_prag False) }
"{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e) / { notFollowedByPragmaChar }
{ token ITspec_prag }
"{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e)
-- Pragmas
| ITinline_prag Bool -- True <=> INLINE, False <=> NOINLINE
+ | ITinline_conlike_prag Bool -- same
| ITspec_prag -- SPECIALISE
| ITspec_inline_prag Bool -- SPECIALISE INLINE (or NOINLINE)
| ITsource_prag
import StaticFlags ( opt_SccProfilingOn, opt_Hpc )
import Type ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind )
import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
- Activation(..), defaultInlineSpec )
+ Activation(..), RuleMatchInfo(..), defaultInlineSpec )
import DynFlags
import OrdList
import HaddockParse
'using' { L _ ITusing } -- for list transform extension
'{-# INLINE' { L _ (ITinline_prag _) }
+ '{-# INLINE_CONLIKE' { L _ (ITinline_conlike_prag _) }
'{-# SPECIALISE' { L _ ITspec_prag }
'{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _) }
'{-# SOURCE' { L _ ITsource_prag }
| infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
| n <- unLoc $3 ] }
| '{-# INLINE' activation qvar '#-}'
- { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 (getINLINE $1)))) }
+ { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 FunLike (getINLINE $1)))) }
+ | '{-# INLINE_CONLIKE' activation qvar '#-}'
+ { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 ConLike (getINLINE_CONLIKE $1)))) }
| '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
{ LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlineSpec)
| t <- $4] }
| '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
- { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 (getSPEC_INLINE $1)))
+ { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 FunLike (getSPEC_INLINE $1)))
| t <- $5] }
| '{-# SPECIALISE' 'instance' inst_type '#-}'
{ LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
getPRIMDOUBLE (L _ (ITprimdouble x)) = x
getTH_ID_SPLICE (L _ (ITidEscape x)) = x
getINLINE (L _ (ITinline_prag b)) = b
+getINLINE_CONLIKE (L _ (ITinline_conlike_prag b)) = b
getSPEC_INLINE (L _ (ITspec_inline_prag b)) = b
getDOCNEXT (L _ (ITdocCommentNext x)) = x
import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
isRdrDataCon, isUnqual, getRdrName, isQual,
setRdrNameSpace, showRdrName )
-import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
+import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo,
+ InlinePragma(..), InlineSpec(..),
+ alwaysInlineSpec, neverInlineSpec )
import Lexer ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled )
import TysWiredIn ( unitTyCon )
import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
-mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
+mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec
-- The Maybe is becuase the user can omit the activation spec (and usually does)
-mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
-mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
-mkInlineSpec (Just act) inl = Inline act inl
+mkInlineSpec Nothing match_info True = alwaysInlineSpec match_info
+ -- INLINE
+mkInlineSpec Nothing match_info False = neverInlineSpec match_info
+ -- NOINLINE
+mkInlineSpec (Just act) match_info inl = Inline (InlinePragma act match_info) inl
-----------------------------------------------------------------------------
#include "HsVersions.h"
-import Id ( Id, idType, idInlinePragma, zapIdOccInfo )
+import Id ( Id, idType, idInlineActivation, zapIdOccInfo )
import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap )
import DataCon ( isUnboxedTupleCon )
import Type ( tyConAppArgs )
Nothing -> (addCSEnvItem env' rhs' (Var id'), (id', rhs'))
where
(env', id') = addBinder env id
- rhs' | isAlwaysActive (idInlinePragma id) = cseExpr env' rhs
- | otherwise = rhs
+ rhs' | isAlwaysActive (idInlineActivation id) = cseExpr env' rhs
+ | otherwise = rhs
-- See Note [CSE for INLINE and NOINLINE]
tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
where
fun_uniq = idUnique fun
fun_uds = mkOneOcc env fun (valArgCount args > 0)
- is_pap = isDataConWorkId fun || valArgCount args < idArity fun
+ is_pap = isConLikeId fun || valArgCount args < idArity fun
-- Hack for build, fold, runST
args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})
= not (isNilOL fs) && want_to_float && can_float
where
- want_to_float = isTopLevel lvl || exprIsCheap rhs
+ want_to_float = isTopLevel lvl || exprIsExpandable rhs
can_float = case ff of
FltLifted -> True
FltOkSpec -> isNotTopLevel lvl && isNonRec rec
substUnfolding _ NoUnfolding = NoUnfolding
substUnfolding _ (OtherCon cons) = OtherCon cons
substUnfolding env (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr env rhs)
-substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g
+substUnfolding env (CoreUnfolding rhs t u v w g) = CoreUnfolding (substExpr env rhs) t u v w g
------------------
substWorker :: SimplEnv -> WorkerInfo -> WorkerInfo
vanilla_discounts, arg_discounts :: [Int]
vanilla_discounts = repeat 0
arg_discounts = case idUnfolding fun of
- CoreUnfolding _ _ _ _ (UnfoldIfGoodArgs _ discounts _ _)
+ CoreUnfolding _ _ _ _ _ (UnfoldIfGoodArgs _ discounts _ _)
-> discounts ++ vanilla_discounts
_ -> vanilla_discounts
where
phase = getMode env
active = case phase of
- SimplGently -> isAlwaysActive prag
- SimplPhase n _ -> isActive n prag
- prag = idInlinePragma bndr
+ SimplGently -> isAlwaysActive act
+ SimplPhase n _ -> isActive n act
+ act = idInlineActivation bndr
try_once in_lam int_cxt -- There's one textual occurrence
| not in_lam = isNotTopLevel top_lvl || early_phase
where
active = case getMode env of
- SimplGently -> isAlwaysActive prag
- SimplPhase n _ -> isActive n prag
- prag = idInlinePragma bndr
+ SimplGently -> isAlwaysActive act
+ SimplPhase n _ -> isActive n act
+ act = idInlineActivation bndr
activeInline :: SimplEnv -> OutId -> Bool
activeInline env id
-- and they are now constructed as Compulsory unfoldings (in MkId)
-- so they'll happen anyway.
- SimplPhase n _ -> isActive n prag
+ SimplPhase n _ -> isActive n act
where
- prag = idInlinePragma id
+ act = idInlineActivation id
activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool)
-- Nothing => No rules at all
where
is_val = n_val_args > 0 -- There is at least one arg
-- ...and the fun a constructor or PAP
- && (isDataConWorkId fun || n_val_args < idArity fun)
+ && (isConLikeId fun || n_val_args < idArity fun)
go _ env other
= return (False, env, other)
\end{code}
= return (addNonRecWithUnf env new_bndr new_rhs unfolding wkr)
where
unfolding | omit_unfolding = NoUnfolding
- | otherwise = mkUnfolding (isTopLevel top_lvl) new_rhs
+ | otherwise = mkUnfolding (isTopLevel top_lvl) new_rhs
old_info = idInfo old_bndr
occ_info = occInfo old_info
wkr = substWorker env (workerInfo old_info)
import CoreSyn -- All of it
import OccurAnal ( occurAnalyseExpr )
import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars )
-import CoreUtils ( tcEqExprX, exprType )
+import CoreUtils ( exprType )
import PprCore ( pprRules )
-import Type ( Type, TvSubstEnv )
+import Type ( Type, TvSubstEnv, tcEqTypeX )
import TcType ( tcSplitTyConApp_maybe )
import CoreTidy ( tidyRules )
import Id
match menv subst e1 (Note _ e2)
= match menv subst e1 e2
- -- Note [Notes in RULE matching]
- -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- -- Look through Notes. In particular, we don't want to
- -- be confused by InlineMe notes. Maybe we should be more
- -- careful about profiling notes, but for now I'm just
- -- riding roughshod over them.
- --- See Note [Notes in call patterns] in SpecConstr
-
--- Here is another important rule: if the term being matched is a
--- variable, we expand it so long as its unfolding is a WHNF
--- (Its occurrence information is not necessarily up to date,
--- so we don't use it.)
-match menv subst e1 (Var v2)
- | isCheapUnfolding unfolding
- = match menv subst e1 (unfoldingTemplate unfolding)
+ -- See Note [Notes in RULE matching]
+
+match menv subst e1 (Var v2) -- Note [Expanding variables]
+ | not (locallyBoundR rn_env v2) -- Note [Do not expand locally-bound variables]
+ , Just e2' <- expandId v2'
+ = match (menv { me_env = nukeRnEnvR rn_env }) subst e1 e2'
where
- rn_env = me_env menv
- unfolding = idUnfolding (lookupRnInScope rn_env (rnOccR rn_env v2))
+ v2' = lookupRnInScope rn_env v2
+ rn_env = me_env menv
-- Notice that we look up v2 in the in-scope set
-- See Note [Lookup in-scope]
- -- Remember to apply any renaming first (hence rnOccR)
-
--- Note [Matching lets]
--- ~~~~~~~~~~~~~~~~~~~~
--- Matching a let-expression. Consider
--- RULE forall x. f (g x) = <rhs>
--- and target expression
--- f (let { w=R } in g E))
--- Then we'd like the rule to match, to generate
--- let { w=R } in (\x. <rhs>) E
--- In effect, we want to float the let-binding outward, to enable
--- the match to happen. This is the WHOLE REASON for accumulating
--- bindings in the SubstEnv
---
--- We can only do this if
--- (a) Widening the scope of w does not capture any variables
--- We use a conservative test: w is not already in scope
--- If not, we clone the binders, and substitute
--- (b) The free variables of R are not bound by the part of the
--- target expression outside the let binding; e.g.
--- f (\v. let w = v+1 in g E)
--- Here we obviously cannot float the let-binding for w.
---
--- You may think rule (a) would never apply, because rule matching is
--- mostly invoked from the simplifier, when we have just run substExpr
--- over the argument, so there will be no shadowing anyway.
--- The fly in the ointment is that the forall'd variables of the
--- RULE itself are considered in scope.
---
--- I though of various cheapo ways to solve this tiresome problem,
--- but ended up doing the straightforward thing, which is to
--- clone the binders if they are in scope. It's tiresome, and
--- potentially inefficient, because of the calls to substExpr,
--- but I don't think it'll happen much in pracice.
-
-{- Cases to think about
- (let x=y+1 in \x. (x,x))
- --> let x=y+1 in (\x1. (x1,x1))
- (\x. let x = y+1 in (x,x))
- --> let x1 = y+1 in (\x. (x1,x1)
- (let x=y+1 in (x,x), let x=y-1 in (x,x))
- --> let x=y+1 in let x1=y-1 in ((x,x),(x1,x1))
-
-Watch out!
- (let x=y+1 in let z=x+1 in (z,z)
- --> matches (p,p) but watch out that the use of
- x on z's rhs is OK!
-I'm removing the cloning because that makes the above case
-fail, because the inner let looks as if it has locally-bound vars -}
+ -- No need to apply any renaming first (hence no rnOccR)
+ -- becuase of the not-locallyBoundR
match menv (tv_subst, id_subst, binds) e1 (Let bind e2)
- | all freshly_bound bndrs,
- not (any locally_bound bind_fvs)
+ | all freshly_bound bndrs -- See Note [Matching lets]
+ , not (any (locallyBoundR rn_env) bind_fvs)
= match (menv { me_env = rn_env' })
(tv_subst, id_subst, binds `snocOL` bind')
e1 e2'
rn_env = me_env menv
bndrs = bindersOf bind
bind_fvs = varSetElems (bindFreeVars bind)
- locally_bound x = inRnEnvR rn_env x
freshly_bound x = not (x `rnInScope` rn_env)
- bind' = bind
- e2' = e2
+ bind' = bind
+ e2' = e2
rn_env' = extendRnInScopeList rn_env bndrs
-{-
- (rn_env', bndrs') = mapAccumL rnBndrR rn_env bndrs
- s_prs = [(bndr, Var bndr') | (bndr,bndr') <- zip bndrs bndrs', bndr /= bndr']
- subst = mkSubst (rnInScopeSet rn_env) emptyVarEnv (mkVarEnv s_prs)
- (bind', e2') | null s_prs = (bind, e2)
- | otherwise = (s_bind, substExpr subst e2)
- s_bind = case bind of
- NonRec {} -> NonRec (head bndrs') (head rhss)
- Rec {} -> Rec (bndrs' `zip` map (substExpr subst) rhss)
--}
match _ subst (Lit lit1) (Lit lit2)
| lit1 == lit2
= do { subst1 <- match_ty menv subst co1 co2
; match menv subst1 e1 e2 }
-{- REMOVING OLD CODE: I think that the above handling for let is
- better than the stuff here, which looks
- pretty suspicious to me. SLPJ Sept 06
--- This is an interesting rule: we simply ignore lets in the
--- term being matched against! The unfolding inside it is (by assumption)
--- already inside any occurrences of the bound variables, so we'll expand
--- them when we encounter them. This gives a chance of matching
--- forall x,y. f (g (x,y))
--- against
--- f (let v = (a,b) in g v)
-
-match menv subst e1 (Let bind e2)
- = match (menv { me_env = rn_env' }) subst e1 e2
- where
- (rn_env', _bndrs') = mapAccumL rnBndrR (me_env menv) (bindersOf bind)
- -- It's important to do this renaming, so that the bndrs
- -- are brought into the local scope. For example:
- -- Matching
- -- forall f,x,xs. f (x:xs)
- -- against
- -- f (let y = e in (y:[]))
- -- We must not get success with x->y! So we record that y is
- -- locally bound (with rnBndrR), and proceed. The Var case
- -- will fail when trying to bind x->y
--}
-
-- Everything else fails
match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr e1) $$ (text "e2:" <+> ppr e2)) $
Nothing
-- c.f. match_ty below
; return (tv_subst', extendVarEnv id_subst v1' e2, binds) }
- Just e1' | tcEqExprX (nukeRnEnvL rn_env) e1' e2
+ Just e1' | eqExpr (nukeRnEnvL rn_env) e1' e2
-> Just subst
| otherwise
; return (tv_subst', id_subst, binds) }
\end{code}
+Note [Expanding variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here is another Very Important rule: if the term being matched is a
+variable, we expand it so long as its unfolding is "expandable". (Its
+occurrence information is not necessarily up to date, so we don't use
+it.) By "expandable" we mean a WHNF or a "constructor-like" application.
+This is the key reason for "constructor-like" Ids. If we have
+ {-# NOINLINE [1] CONLIKE g #-}
+ {-# RULE f (g x) = h x #-}
+then in the term
+ let v = g 3 in ....(f v)....
+we want to make the rule fire, to replace (f v) with (h 3).
+
+Note [Do not expand locally-bound variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Do *not* expand locally-bound variables, else there's a worry that the
+unfolding might mention variables that are themselves renamed.
+Example
+ case x of y { (p,q) -> ...y... }
+Don't expand 'y' to (p,q) because p,q might themselves have been
+renamed. Essentially we only expand unfoldings that are "outside"
+the entire match.
+
+Hence, (a) the guard (not (isLocallyBoundR v2))
+ (b) when we expand we nuke the renaming envt (nukeRnEnvR).
+
+Note [Notes in RULE matching]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Look through Notes. In particular, we don't want to
+be confused by InlineMe notes. Maybe we should be more
+careful about profiling notes, but for now I'm just
+riding roughshod over them.
+See Note [Notes in call patterns] in SpecConstr
+
+Note [Matching lets]
+~~~~~~~~~~~~~~~~~~~~
+Matching a let-expression. Consider
+ RULE forall x. f (g x) = <rhs>
+and target expression
+ f (let { w=R } in g E))
+Then we'd like the rule to match, to generate
+ let { w=R } in (\x. <rhs>) E
+In effect, we want to float the let-binding outward, to enable
+the match to happen. This is the WHOLE REASON for accumulating
+bindings in the SubstEnv
+
+We can only do this if
+ (a) Widening the scope of w does not capture any variables
+ We use a conservative test: w is not already in scope
+ If not, we clone the binders, and substitute
+ (b) The free variables of R are not bound by the part of the
+ target expression outside the let binding; e.g.
+ f (\v. let w = v+1 in g E)
+ Here we obviously cannot float the let-binding for w.
+
+You may think rule (a) would never apply, because rule matching is
+mostly invoked from the simplifier, when we have just run substExpr
+over the argument, so there will be no shadowing anyway.
+The fly in the ointment is that the forall'd variables of the
+RULE itself are considered in scope.
+
+I though of various ways to solve (a). One plan was to
+clone the binders if they are in scope. But watch out!
+ (let x=y+1 in let z=x+1 in (z,z)
+ --> should match (p,p) but watch out that
+ the use of x on z's rhs is OK!
+If we clone x, then the let-binding for 'z' is then caught by (b),
+at least unless we elaborate the RnEnv stuff a bit.
+
+So for we simply fail to match unless both (a) and (b) hold.
+
+Other cases to think about
+ (let x=y+1 in \x. (x,x))
+ --> let x=y+1 in (\x1. (x1,x1))
+ (\x. let x = y+1 in (x,x))
+ --> let x1 = y+1 in (\x. (x1,x1)
+ (let x=y+1 in (x,x), let x=y-1 in (x,x))
+ --> let x=y+1 in let x1=y-1 in ((x,x),(x1,x1))
+
Note [Lookup in-scope]
~~~~~~~~~~~~~~~~~~~~~~
That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'
is so important.
+\begin{code}
+eqExpr :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
+-- ^ A kind of shallow equality used in rule matching, so does
+-- /not/ look through newtypes or predicate types
+
+eqExpr env (Var v1) (Var v2)
+ | rnOccL env v1 == rnOccR env v2
+ = True
+
+-- The next two rules expand non-local variables
+-- C.f. Note [Expanding variables]
+-- and Note [Do not expand locally-bound variables]
+eqExpr env (Var v1) e2
+ | not (locallyBoundL env v1)
+ , Just e1' <- expandId (lookupRnInScope env v1)
+ = eqExpr (nukeRnEnvL env) e1' e2
+
+eqExpr env e1 (Var v2)
+ | not (locallyBoundR env v2)
+ , Just e2' <- expandId (lookupRnInScope env v2)
+ = eqExpr (nukeRnEnvR env) e1 e2'
+
+eqExpr _ (Lit lit1) (Lit lit2) = lit1 == lit2
+eqExpr env (App f1 a1) (App f2 a2) = eqExpr env f1 f2 && eqExpr env a1 a2
+eqExpr env (Lam v1 e1) (Lam v2 e2) = eqExpr (rnBndr2 env v1 v2) e1 e2
+eqExpr env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eqExpr env e1 e2
+eqExpr env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && eqExpr env e1 e2
+eqExpr env (Type t1) (Type t2) = tcEqTypeX env t1 t2
+
+eqExpr env (Let (NonRec v1 r1) e1)
+ (Let (NonRec v2 r2) e2) = eqExpr env r1 r2
+ && eqExpr (rnBndr2 env v1 v2) e1 e2
+eqExpr env (Let (Rec ps1) e1)
+ (Let (Rec ps2) e2) = equalLength ps1 ps2
+ && and (zipWith eq_rhs ps1 ps2)
+ && eqExpr env' e1 e2
+ where
+ env' = foldl2 rn_bndr2 env ps2 ps2
+ rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
+ eq_rhs (_,r1) (_,r2) = eqExpr env' r1 r2
+eqExpr env (Case e1 v1 t1 a1)
+ (Case e2 v2 t2 a2) = eqExpr env e1 e2
+ && tcEqTypeX env t1 t2
+ && equalLength a1 a2
+ && and (zipWith (eq_alt env') a1 a2)
+ where
+ env' = rnBndr2 env v1 v2
+
+eqExpr _ _ _ = False
+
+eq_alt :: RnEnv2 -> CoreAlt -> CoreAlt -> Bool
+eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && eqExpr (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}
+
+Auxiliary functions
+
+\begin{code}
+locallyBoundL, locallyBoundR :: RnEnv2 -> Var -> Bool
+locallyBoundL rn_env v = inRnEnvL rn_env v
+locallyBoundR rn_env v = inRnEnvR rn_env v
+
+
+expandId :: Id -> Maybe CoreExpr
+expandId id
+ | isExpandableUnfolding unfolding = Just (unfoldingTemplate unfolding)
+ | otherwise = Nothing
+ where
+ unfolding = idUnfolding id
+\end{code}
%************************************************************************
%* *
-\subsection{Checking a program for failing rule applications}
+ Rule-check the program
%* *
%************************************************************************
------------------------------------------------------
- Game plan
------------------------------------------------------
-
-We want to know what sites have rules that could have fired but didn't.
-This pass runs over the tree (without changing it) and reports such.
+ We want to know what sites have rules that could have fired but didn't.
+ This pass runs over the tree (without changing it) and reports such.
\begin{code}
-- | Report partial matches for rules beginning with the specified
#include "HsVersions.h"
import Id ( Id, idName, idType, mkUserLocal, idCoreRules,
- idInlinePragma, setInlinePragma, setIdUnfolding,
- isLocalId )
+ idInlineActivation, setInlineActivation, setIdUnfolding,
+ isLocalId )
import TcType ( Type, mkTyVarTy, tcSplitSigmaTy,
tyVarsOfTypes, tyVarsOfTheta, isClassPred,
tcCmpType, isUnLiftedType
(tyvars, theta, _) = tcSplitSigmaTy fn_type
n_tyvars = length tyvars
n_dicts = length theta
- inline_prag = idInlinePragma fn
+ inline_act = idInlineActivation fn
-- It's important that we "see past" any INLINE pragma
-- else we'll fail to specialise an INLINE thing
rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args))
spec_env_rule = mkLocalRule
rule_name
- inline_prag -- Note [Auto-specialisation and RULES]
+ inline_act -- Note [Auto-specialisation and RULES]
(idName fn)
(poly_tyvars ++ inst_dict_ids)
inst_args
-- Add the { d1' = dx1; d2' = dx2 } usage stuff
final_uds = foldr addDictBind rhs_uds dx_binds
- spec_pr | inline_rhs = (spec_f `setInlinePragma` inline_prag, Note InlineMe spec_rhs)
+ spec_pr | inline_rhs = (spec_f `setInlineActivation` inline_act, Note InlineMe spec_rhs)
| otherwise = (spec_f, spec_rhs)
; return (Just (spec_pr, final_uds, spec_env_rule)) } }
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We transfer to the specialised function any INLINE stuff from the
original. This means (a) the Activation in the IdInfo, and (b) any
-InlineMe on the RHS.
+InlineMe on the RHS. We do not, however, transfer the RuleMatchInfo
+since we do not expect the specialisation to occur in rewrite rules.
This is a change (Jun06). Previously the idea is that the point of
inlining was precisely to specialise the function at its call site,
import CoreArity ( exprArity )
import DataCon ( dataConTyCon )
import TyCon ( isProductTyCon, isRecursiveTyCon )
-import Id ( Id, idType, idInlinePragma,
+import Id ( Id, idType, idInlineActivation,
isDataConWorkId, isGlobalId, idArity,
#ifdef OLD_STRICTNESS
idDemandInfo, idStrictness, idCprInfo, idName,
mkSigTy top_lvl rec_flag id rhs dmd_ty
= mk_sig_ty never_inline thunk_cpr_ok rhs dmd_ty
where
- never_inline = isNeverActive (idInlinePragma id)
+ never_inline = isNeverActive (idInlineActivation id)
maybe_id_dmd = idNewDemandInfo_maybe id
-- Is Nothing the first time round
import Var
import Id ( Id, idType, isOneShotLambda,
setIdNewStrictness, mkWorkerId,
- setIdWorkerInfo, setInlinePragma,
+ setIdWorkerInfo, setInlineActivation,
setIdArity, idInfo )
import MkId ( lazyIdKey, lazyIdUnfolding )
import Type ( Type )
)
import UniqSupply
import Unique ( hasKey )
-import BasicTypes ( RecFlag(..), isNonRec, isNeverActive )
+import BasicTypes ( RecFlag(..), isNonRec, isNeverActive,
+ Activation, inlinePragmaActivation )
import VarEnv ( isEmptyVarEnv )
import Maybes ( orElse )
import WwLib
| -- isNonRec is_rec && -- Now omitted: see Note [Don't w/w inline things]
certainlyWillInline unfolding
- || isNeverActive inline_prag
+ || isNeverActive inline_act
-- No point in worker/wrappering if the thing is never inlined!
-- Because the no-inline prag will prevent the wrapper ever
-- being inlined at a call site.
splitThunk new_fn_id rhs
| is_fun && worthSplittingFun wrap_dmds res_info
- = splitFun new_fn_id fn_info wrap_dmds res_info inline_prag rhs
+ = splitFun new_fn_id fn_info wrap_dmds res_info inline_act rhs
| otherwise
= return [ (new_fn_id, rhs) ]
fn_info = idInfo fn_id
maybe_fn_dmd = newDemandInfo fn_info
unfolding = unfoldingInfo fn_info
- inline_prag = inlinePragInfo fn_info
+ inline_act = inlinePragmaActivation (inlinePragInfo fn_info)
-- In practice it always will have a strictness
-- signature, even if it's a uninformative one
is_thunk = not is_fun && not (exprIsHNF rhs)
---------------------
-splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> InlinePragInfo -> Expr Var
+splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Activation -> Expr Var
-> UniqSM [(Id, CoreExpr)]
-splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs
+splitFun fn_id fn_info wrap_dmds res_info inline_act rhs
= WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) )
(do {
-- The arity should match the signature
; let
work_rhs = work_fn rhs
work_id = mkWorkerId work_uniq fn_id (exprType work_rhs)
- `setInlinePragma` inline_prag
- -- Any inline pragma (which sets when inlining is active)
+ `setInlineActivation` inline_act
+ -- Any inline activation (which sets when inlining is active)
-- on the original function is duplicated on the worker and wrapper
-- It *matters* that the pragma stays on the wrapper
-- It seems sensible to have it on the worker too, although we
-- can't think of a compelling reason. (In ptic, INLINE things are
- -- not w/wd)
+ -- not w/wd). However, the RuleMatchInfo is not transferred since
+ -- it does not make sense for workers to be constructorlike.
`setIdNewStrictness` StrictSig (mkTopDmdType work_demands work_res_info)
-- Even though we may not be at top level,
-- it's ok to give it an empty DmdEnv
-- Create the result bindings
; let dict_constr = classDataCon clas
inline_prag | null dfun_dicts = []
- | otherwise = [L loc (InlinePrag (Inline AlwaysActive True))]
+ | otherwise = [L loc (InlinePrag (alwaysInlineSpec FunLike))]
-- Always inline the dfun; this is an experimental decision
-- because it makes a big performance difference sometimes.
-- Often it means we can do the method selection, and then
projects / ghc-hetmet.git / commitdiff