From: simonpj@microsoft.com Date: Wed, 18 Mar 2009 10:59:11 +0000 (+0000) Subject: Add the notion of "constructor-like" Ids for rule-matching X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=4bc25e8c30559b7a6a87b39afcc79340ae778788 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. --- diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 04ed8fa..fad6533 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -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 diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index 676d6cf..2f5e93c 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -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} diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index 07cc181..9889dbc 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -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} diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 1b3a9d7..4d8f3cb 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -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} diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 496d7a0..eaeba10 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -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 diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 5d33b0f..379da8a 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -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} - %************************************************************************ %* * diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 1504ab9..e210937 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -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 diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 4c144b8..80a7cf6 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -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 diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 0c40318..7071ab7 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -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. diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 7a27401..1a4a65a 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -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 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index b679cf6..51e5f8a 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -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") diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 22c1756..8cfc08f 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -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 diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 60fd726..5c78927 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -561,7 +561,7 @@ addExternal (id,rhs) needed 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) diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 07ee66f..5c595f5 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -244,6 +244,12 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } { 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) @@ -490,6 +496,7 @@ data Token -- 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 diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index d9df620..5fbbcad 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -47,7 +47,7 @@ import Module 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 @@ -254,6 +254,7 @@ incorrect. '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 } @@ -1287,12 +1288,14 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } | 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)) } @@ -2013,6 +2016,7 @@ getPRIMFLOAT (L _ (ITprimfloat x)) = x 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 diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index bccf27f..382b333 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -58,7 +58,9 @@ import TypeRep ( Kind ) 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(..), @@ -923,11 +925,13 @@ mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg 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 ----------------------------------------------------------------------------- diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs index d4aef90..54490f4 100644 --- a/compiler/simplCore/CSE.lhs +++ b/compiler/simplCore/CSE.lhs @@ -10,7 +10,7 @@ module CSE ( #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 ) @@ -201,8 +201,8 @@ do_one env (id, rhs) 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 diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 83fbad1..c5f323e 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -864,7 +864,7 @@ occAnalApp env (Var fun, args) 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 diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index a2e06a0..0a7575a 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -356,7 +356,7 @@ doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool 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 @@ -677,7 +677,7 @@ substUnfolding :: SimplEnv -> Unfolding -> Unfolding 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 diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 1c6768d..c212893 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -370,7 +370,7 @@ mkArgInfo fun n_val_args call_cont 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 @@ -622,9 +622,9 @@ preInlineUnconditionally env top_lvl bndr rhs 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 @@ -778,9 +778,9 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding 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 @@ -801,9 +801,9 @@ 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 diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 10965a1..4f75769 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -461,7 +461,7 @@ prepareRhs env0 rhs0 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} @@ -578,7 +578,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs = 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) diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index d788b1b..0cf7a44 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -32,9 +32,9 @@ module Rules ( 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 @@ -490,79 +490,23 @@ match menv subst (Var v1) e2 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) = --- 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. ) 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' @@ -570,21 +514,10 @@ match menv (tv_subst, id_subst, binds) e1 (Let bind 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 @@ -632,32 +565,6 @@ match menv subst (Cast e1 co1) (Cast e2 co2) = 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 @@ -691,7 +598,7 @@ match_var menv subst@(tv_subst, id_subst, binds) v1 e2 -- 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 @@ -749,6 +656,85 @@ match_ty menv (tv_subst, id_subst, binds) ty1 ty2 ; 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) = +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. ) 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] ~~~~~~~~~~~~~~~~~~~~~~ @@ -785,19 +771,89 @@ at all. 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 diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 4d8efdd..015332f 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -15,8 +15,8 @@ module Specialise ( specProgram ) where #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 @@ -829,7 +829,7 @@ specDefn subst calls fn rhs (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 @@ -913,7 +913,7 @@ specDefn subst calls fn rhs 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 @@ -922,7 +922,7 @@ specDefn subst calls fn rhs -- 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)) } } @@ -1068,7 +1068,8 @@ Note [Inline specialisations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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, diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 41f574a..6dc0fb7 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -29,7 +29,7 @@ import CoreUtils ( exprIsHNF, exprIsTrivial ) 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, @@ -463,7 +463,7 @@ mkSigTy :: TopLevelFlag -> RecFlag -> Id -> CoreExpr -> DmdType -> (DmdEnv, Stri 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 diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs index 71f9ef8..30754e5 100644 --- a/compiler/stranal/WorkWrap.lhs +++ b/compiler/stranal/WorkWrap.lhs @@ -15,7 +15,7 @@ import CoreArity ( exprArity ) import Var import Id ( Id, idType, isOneShotLambda, setIdNewStrictness, mkWorkerId, - setIdWorkerInfo, setInlinePragma, + setIdWorkerInfo, setInlineActivation, setIdArity, idInfo ) import MkId ( lazyIdKey, lazyIdUnfolding ) import Type ( Type ) @@ -25,7 +25,8 @@ import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), ) 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 @@ -196,7 +197,7 @@ tryWW is_rec fn_id rhs | -- 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. @@ -207,7 +208,7 @@ tryWW is_rec fn_id rhs 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) ] @@ -216,7 +217,7 @@ tryWW is_rec 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 @@ -236,9 +237,9 @@ tryWW is_rec fn_id rhs 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 @@ -247,13 +248,14 @@ splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs ; 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 diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 896ae44..74879f3 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -755,7 +755,7 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags) -- 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