From: simonpj@microsoft.com Date: Wed, 2 Dec 2009 17:42:56 +0000 (+0000) Subject: More work on the simplifier's inlining strategies X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=c86161c5cf11de77e911fcb9e1e2bd1f8bd80b42 More work on the simplifier's inlining strategies This patch collects a small raft of related changes * Arrange that during (a) rule matching and (b) uses of exprIsConApp_maybe we "look through" unfoldings only if they are active in the phase. Doing this for (a) required a bit of extra plumbing in the rule matching code, but I think it's worth it. One wrinkle is that even if inlining is off (in the 'gentle' phase of simplification) during rule matching we want to "look through" things with inlinings. See SimplUtils.activeUnfInRule. This fixes a long-standing bug, where things that were supposed to be (say) NOINLINE, could still be poked into via exprIsConApp_maybe. * In the above cases, also check for (non-rule) loop breakers; we never look through these. This fixes a bug that could make the simplifier diverge (and did for Roman). Test = simplCore/should_compile/dfun-loop * Try harder not to choose a DFun as a loop breaker. This is just a small adjustment in the OccurAnal scoring function * In the scoring function in OccurAnal, look at the InlineRule unfolding (if there is one) not the actual RHS, beause the former is what'll be inlined. * Make the application of any function to dictionary arguments CONLIKE. Thus (f d1 d2) is CONLIKE. Encapsulated in CoreUtils.isExpandableApp Reason: see Note [Expandable overloadings] in CoreUtils * Make case expressions seem slightly smaller in CoreUnfold. This reverses an unexpected consequences of charging for alternatives. Refactorings ~~~~~~~~~~~~ * Signficantly refactor the data type for Unfolding (again). The result is much nicer. * Add type synonym BasicTypes.CompilerPhase = Int and use it Many of the files touched by this patch are simply knock-on consequences of these two refactorings. --- diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 1eacea9..aaeb3bc 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -345,7 +345,7 @@ mkDataConIds wrap_name wkr_name data_con -- ...(let w = C x in ...(w p q)...)... -- we want to see that w is strict in its two arguments - wrap_unf = mkInlineRule InlSat wrap_rhs (length dict_args + length id_args) + wrap_unf = mkInlineRule needSaturated wrap_rhs (length dict_args + length id_args) wrap_rhs = mkLams wrap_tvs $ mkLams eq_args $ mkLams dict_args $ mkLams id_args $ @@ -520,16 +520,16 @@ mkDictSelId no_unf name clas | otherwise = Case (Var dict_id) dict_id (idType the_arg_id) [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)] -dictSelRule :: Int -> Arity -> [CoreExpr] -> Maybe CoreExpr +dictSelRule :: Int -> Arity -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr -- Oh, very clever -- op_i t1..tk (df s1..sn d1..dm) = op_i_helper s1..sn d1..dm -- op_i t1..tk (D t1..tk op1 ... opm) = opi -- -- NB: the data constructor has the same number of type args as the class op -dictSelRule index n_ty_args args +dictSelRule index n_ty_args id_unf args | (dict_arg : _) <- drop n_ty_args args - , Just (_, _, val_args) <- exprIsConApp_maybe dict_arg + , Just (_, _, val_args) <- exprIsConApp_maybe id_unf dict_arg = Just (val_args !! index) | otherwise = Nothing @@ -958,12 +958,12 @@ seqId = pcMiscPrelId seqName ty info , ru_try = match_seq_of_cast } -match_seq_of_cast :: [CoreExpr] -> Maybe CoreExpr +match_seq_of_cast :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr -- See Note [Built-in RULES for seq] -match_seq_of_cast [Type _, Type res_ty, Cast scrut co, expr] +match_seq_of_cast _ [Type _, Type res_ty, Cast scrut co, expr] = Just (Var seqId `mkApps` [Type (fst (coercionKind co)), Type res_ty, scrut, expr]) -match_seq_of_cast _ = Nothing +match_seq_of_cast _ _ = Nothing ------------------------------------------------ lazyId :: Id -- See Note [lazyId magic] diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index 3ff583e..1e8c9e7 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -421,7 +421,8 @@ idUnfoldingVars :: Id -> VarSet -- we might get out-of-scope variables idUnfoldingVars id = case realIdUnfolding id of - CoreUnfolding { uf_tmpl = rhs, uf_guidance = InlineRule {} } + CoreUnfolding { uf_tmpl = rhs, uf_src = src } + | isInlineRuleSource src -> exprFreeVars rhs DFunUnfolding _ args -> exprsFreeVars args _ -> emptyVarSet diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index b02bc80..b5d7fde 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -13,7 +13,7 @@ module CoreSubst ( -- ** Substituting into expressions and related types deShadowBinds, substSpec, substRulesForImportedIds, substTy, substExpr, substBind, substUnfolding, - substInlineRuleInfo, lookupIdSubst, lookupTvSubst, substIdOcc, + substUnfoldingSource, lookupIdSubst, lookupTvSubst, substIdOcc, -- ** Operations on substitutions emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, @@ -507,28 +507,39 @@ substUnfolding :: Subst -> Unfolding -> Unfolding substUnfolding subst (DFunUnfolding con args) = DFunUnfolding con (map (substExpr subst) args) -substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_guidance = guide@(InlineRule {}) }) +substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) -- Retain an InlineRule! + | not (isInlineRuleSource src) -- Always zap a CoreUnfolding, to save substitution work + = NoUnfolding + | otherwise -- But keep an InlineRule! = seqExpr new_tmpl `seq` - new_info `seq` - unf { uf_tmpl = new_tmpl, uf_guidance = guide { ir_info = new_info } } + new_src `seq` + unf { uf_tmpl = new_tmpl, uf_src = new_src } where new_tmpl = substExpr subst tmpl - new_info = substInlineRuleInfo subst (ir_info guide) - -substUnfolding _ (CoreUnfolding {}) = NoUnfolding -- Discard - -- Always zap a CoreUnfolding, to save substitution work + new_src = substUnfoldingSource subst src substUnfolding _ unf = unf -- NoUnfolding, OtherCon ------------------- -substInlineRuleInfo :: Subst -> InlineRuleInfo -> InlineRuleInfo -substInlineRuleInfo (Subst in_scope ids _) (InlWrapper wkr) - | Just (Var w1) <- lookupVarEnv ids wkr = InlWrapper w1 - | Just w1 <- lookupInScope in_scope wkr = InlWrapper w1 - | otherwise = WARN( True, text "Interesting! CoreSubst.substWorker:" <+> ppr wkr ) - InlVanilla -- Note [Worker inlining] -substInlineRuleInfo _ info = info +substUnfoldingSource :: Subst -> UnfoldingSource -> UnfoldingSource +substUnfoldingSource (Subst in_scope ids _) (InlineWrapper wkr) + | Just wkr_expr <- lookupVarEnv ids wkr + = case wkr_expr of + Var w1 -> InlineWrapper w1 + _other -> WARN( True, text "Interesting! CoreSubst.substWorker1:" <+> ppr wkr + <+> equals <+> ppr wkr_expr ) -- Note [Worker inlining] + InlineRule -- It's not a wrapper any more, but still inline it! + + | Just w1 <- lookupInScope in_scope wkr = InlineWrapper w1 + | otherwise = WARN( True, text "Interesting! CoreSubst.substWorker2:" <+> ppr wkr ) + -- This can legitimately happen. The worker has been inlined and + -- dropped as dead code, because we don't treat the UnfoldingSource + -- as an "occurrence". + -- Note [Worker inlining] + InlineRule + +substUnfoldingSource _ src = src ------------------ substIdOcc :: Subst -> Id -> Id diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 0724630..5c7cef9 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -35,19 +35,20 @@ module CoreSyn ( isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar, -- * Unfolding data types - Unfolding(..), UnfoldingGuidance(..), InlineRuleInfo(..), InlSatFlag(..), + Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), -- Abstract everywhere but in CoreUnfold.lhs -- ** Constructing 'Unfolding's noUnfolding, evaldUnfolding, mkOtherCon, + unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk, -- ** Predicates and deconstruction on 'Unfolding' unfoldingTemplate, setUnfoldingTemplate, maybeUnfoldingTemplate, otherCons, unfoldingArity, isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, - isExpandableUnfolding, isConLikeUnfolding, + isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, isInlineRule, isInlineRule_maybe, isClosedUnfolding, hasSomeUnfolding, - isStableUnfolding, canUnfold, neverUnfoldGuidance, + isStableUnfolding, canUnfold, neverUnfoldGuidance, isInlineRuleSource, -- * Strictness seqExpr, seqExprs, seqUnfolding, @@ -60,7 +61,7 @@ module CoreSyn ( -- * Core rule data types CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only - RuleName, + RuleName, IdUnfoldingFun, -- ** Operations on 'CoreRule's seqRules, ruleArity, ruleName, ruleIdName, ruleActivation_maybe, @@ -333,13 +334,18 @@ data CoreRule ru_fn :: Name, -- ^ As above ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, -- if it fires, including type arguments - ru_try :: [CoreExpr] -> Maybe CoreExpr + ru_try :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr -- ^ This function does the rewrite. It given too many -- arguments, it simply discards them; the returned 'CoreExpr' -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args } -- See Note [Extra args in rule matching] in Rules.lhs +type IdUnfoldingFun = Id -> Unfolding +-- A function that embodies how to unfold an Id if you need +-- to do that in the Rule. The reason we need to pass this info in +-- is that whether an Id is unfoldable depends on the simplifier phase + isBuiltinRule :: CoreRule -> Bool isBuiltinRule (BuiltinRule {}) = True isBuiltinRule _ = False @@ -408,9 +414,10 @@ data Unfolding | CoreUnfolding { -- An unfolding for an Id with no pragma, or perhaps a NOINLINE pragma -- (For NOINLINE, the phase, if any, is in the InlinePragInfo for this Id.) - uf_tmpl :: CoreExpr, -- Template; occurrence info is correct - uf_arity :: Arity, -- Number of value arguments expected + uf_tmpl :: CoreExpr, -- Template; occurrence info is correct + uf_src :: UnfoldingSource, -- Where the unfolding came from uf_is_top :: Bool, -- True <=> top level binding + uf_arity :: Arity, -- Number of value arguments expected uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard a `seq` on -- this variable uf_is_conlike :: Bool, -- True <=> application of constructor or CONLIKE function @@ -438,18 +445,38 @@ data Unfolding -- uf_guidance: Tells us about the /size/ of the unfolding template ------------------------------------------------ +data UnfoldingSource + = InlineCompulsory -- Something that *has* no binding, so you *must* inline it + -- Only a few primop-like things have this property + -- (see MkId.lhs, calls to mkCompulsoryUnfolding). + -- Inline absolutely always, however boring the context. + + | InlineRule -- From an {-# INLINE #-} pragma; See Note [InlineRules] + + | InlineWrapper Id -- This unfolding is a the wrapper in a + -- worker/wrapper split from the strictness analyser + -- The Id is the worker-id + -- Used to abbreviate the uf_tmpl in interface files + -- which don't need to contain the RHS; + -- it can be derived from the strictness info + + | InlineRhs -- The current rhs of the function + + -- For InlineRhs, the uf_tmpl is replaced each time around + -- For all the others we leave uf_tmpl alone + + -- | 'UnfoldingGuidance' says when unfolding should take place data UnfoldingGuidance - = InlineRule { -- Be very keen to inline this; See Note [InlineRules] - -- The uf_tmpl is the *original* RHS; do *not* replace it on - -- each simlifier run. Hence, the *actual* RHS of the function - -- may be different by now, because it may have been optimised. - - ir_sat :: InlSatFlag, - ir_info :: InlineRuleInfo + = UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl + -- Used (a) for small *and* cheap unfoldings + -- (b) for INLINE functions + -- See Note [INLINE for small functions] in CoreUnfold + ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated + ug_boring_ok :: Bool -- True <=> ok to inline even if the context is boring } - | UnfoldIfGoodArgs { -- Arose from a normal Id; the info here is the + | UnfIfGoodArgs { -- Arose from a normal Id; the info here is the -- result of a simple analysis of the RHS ug_args :: [Int], -- Discount if the argument is evaluated. @@ -462,30 +489,16 @@ data UnfoldingGuidance } -- a context (case (thing args) of ...), -- (where there are the right number of arguments.) - | UnfoldNever -- A variant of UnfoldIfGoodArgs, used for big RHSs - -data InlineRuleInfo - = InlAlways -- Inline absolutely always, however boring the context. - -- There is /no original definition/. Only a few primop-like things - -- have this property (see MkId.lhs, calls to mkCompulsoryUnfolding). + | UnfNever -- The RHS is big, so don't inline it - | InlSmall -- The RHS is very small (eg no bigger than a call), so inline any - -- /saturated/ application, regardless of context - -- See Note [INLINE for small functions] in CoreUnfold +-- Constants for the UnfWhen constructor +needSaturated, unSaturatedOk :: Bool +needSaturated = False +unSaturatedOk = True - | InlVanilla - - | InlWrapper Id -- This unfolding is a the wrapper in a - -- worker/wrapper split from the strictness analyser - -- The Id is the worker-id - -- Used to abbreviate the uf_tmpl in interface files - -- which don't need to contain the RHS; - -- it can be derived from the strictness info - -- [In principle this is orthogonal to the InlSmall/InVanilla thing, - -- but it's convenient to have it here.] - -data InlSatFlag = InlSat | InlUnSat - -- Specifies whether to INLINE only if the thing is applied to 'arity' args +boringCxtNotOk, boringCxtOk :: Bool +boringCxtOk = True +boringCxtNotOk = False ------------------------------------------------ noUnfolding :: Unfolding @@ -509,11 +522,17 @@ seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, seqUnfolding _ = () seqGuidance :: UnfoldingGuidance -> () -seqGuidance (UnfoldIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` () -seqGuidance _ = () +seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` () +seqGuidance _ = () \end{code} \begin{code} +isInlineRuleSource :: UnfoldingSource -> Bool +isInlineRuleSource InlineCompulsory = True +isInlineRuleSource InlineRule = True +isInlineRuleSource (InlineWrapper {}) = True +isInlineRuleSource InlineRhs = False + -- | Retrieves the template of an unfolding: panics if none is known unfoldingTemplate :: Unfolding -> CoreExpr unfoldingTemplate = uf_tmpl @@ -565,20 +584,29 @@ isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expabl isExpandableUnfolding _ = False isInlineRule :: Unfolding -> Bool -isInlineRule (CoreUnfolding { uf_guidance = InlineRule {}}) = True -isInlineRule _ = False - -isInlineRule_maybe :: Unfolding -> Maybe (InlineRuleInfo, InlSatFlag) -isInlineRule_maybe (CoreUnfolding { uf_guidance = - InlineRule { ir_info = inl, ir_sat = sat } }) = Just (inl,sat) -isInlineRule_maybe _ = Nothing +isInlineRule (CoreUnfolding { uf_src = src }) = isInlineRuleSource src +isInlineRule _ = False + +isInlineRule_maybe :: Unfolding -> Maybe (UnfoldingSource, Bool) +isInlineRule_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide }) + | isInlineRuleSource src + = Just (src, unsat_ok) + where + unsat_ok = case guide of + UnfWhen unsat_ok _ -> unsat_ok + _ -> needSaturated +isInlineRule_maybe _ = Nothing + +isCompulsoryUnfolding :: Unfolding -> Bool +isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True +isCompulsoryUnfolding _ = False isStableUnfolding :: Unfolding -> Bool -- True of unfoldings that should not be overwritten -- by a CoreUnfolding for the RHS of a let-binding -isStableUnfolding (CoreUnfolding { uf_guidance = InlineRule {} }) = True -isStableUnfolding (DFunUnfolding {}) = True -isStableUnfolding _ = False +isStableUnfolding (CoreUnfolding { uf_src = src }) = isInlineRuleSource src +isStableUnfolding (DFunUnfolding {}) = True +isStableUnfolding _ = False unfoldingArity :: Unfolding -> Arity unfoldingArity (CoreUnfolding { uf_arity = arity }) = arity @@ -594,15 +622,15 @@ hasSomeUnfolding NoUnfolding = False hasSomeUnfolding _ = True neverUnfoldGuidance :: UnfoldingGuidance -> Bool -neverUnfoldGuidance UnfoldNever = True -neverUnfoldGuidance _ = False +neverUnfoldGuidance UnfNever = True +neverUnfoldGuidance _ = False canUnfold :: Unfolding -> Bool canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g) canUnfold _ = False \end{code} -Note [InlineRule] +Note [InlineRules] ~~~~~~~~~~~~~~~~~ When you say {-# INLINE f #-} diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index fd76f23..0510e90 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -1,4 +1,4 @@ -% +calcU% % (c) The University of Glasgow 2006 % (c) The AQUA Project, Glasgow University, 1994-1998 % @@ -87,9 +87,18 @@ mkImplicitUnfolding expr = mkTopUnfolding (simpleOptExpr expr) mkUnfolding :: Bool -> CoreExpr -> Unfolding mkUnfolding top_lvl expr - = mkCoreUnfolding top_lvl expr arity guidance + = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, + uf_src = InlineRhs, + uf_arity = arity, + uf_is_top = top_lvl, + uf_is_value = exprIsHNF expr, + uf_is_conlike = exprIsConLike expr, + uf_expandable = exprIsExpandable expr, + uf_is_cheap = is_cheap, + uf_guidance = guidance } where - (arity, guidance) = calcUnfoldingGuidance opt_UF_CreationThreshold expr + is_cheap = exprIsCheap expr + (arity, guidance) = calcUnfoldingGuidance is_cheap opt_UF_CreationThreshold expr -- Sometimes during simplification, there's a large let-bound thing -- which has been substituted, and so is now dead; so 'expr' contains -- two copies of the thing while the occurrence-analysed expression doesn't @@ -100,10 +109,12 @@ mkUnfolding top_lvl expr -- it gets fixed up next round. And it should be rare, because large -- let-bound things that are dead are usually caught by preInlineUnconditionally -mkCoreUnfolding :: Bool -> CoreExpr -> Arity -> UnfoldingGuidance -> Unfolding +mkCoreUnfolding :: Bool -> UnfoldingSource -> CoreExpr + -> Arity -> UnfoldingGuidance -> Unfolding -- Occurrence-analyses the expression before capturing it -mkCoreUnfolding top_lvl expr arity guidance +mkCoreUnfolding top_lvl src expr arity guidance = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, + uf_src = src, uf_arity = arity, uf_is_top = top_lvl, uf_is_value = exprIsHNF expr, @@ -117,27 +128,28 @@ mkDFunUnfolding con ops = DFunUnfolding con (map Var ops) mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding mkWwInlineRule id expr arity - = mkCoreUnfolding True (simpleOptExpr expr) arity - (InlineRule { ir_sat = InlUnSat, ir_info = InlWrapper id }) + = mkCoreUnfolding True (InlineWrapper id) + (simpleOptExpr expr) arity + (UnfWhen unSaturatedOk boringCxtNotOk) mkCompulsoryUnfolding :: CoreExpr -> Unfolding mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded - = mkCoreUnfolding True expr - 0 -- Arity of unfolding doesn't matter - (InlineRule { ir_info = InlAlways, ir_sat = InlUnSat }) + = mkCoreUnfolding True InlineCompulsory + expr 0 -- Arity of unfolding doesn't matter + (UnfWhen unSaturatedOk boringCxtOk) -mkInlineRule :: InlSatFlag -> CoreExpr -> Arity -> Unfolding -mkInlineRule sat expr arity - = mkCoreUnfolding True -- Note [Top-level flag on inline rules] +mkInlineRule :: Bool -> CoreExpr -> Arity -> Unfolding +mkInlineRule unsat_ok expr arity + = mkCoreUnfolding True InlineRule -- Note [Top-level flag on inline rules] expr' arity - (InlineRule { ir_sat = sat, ir_info = info }) + (UnfWhen unsat_ok boring_ok) where expr' = simpleOptExpr expr - info = if small then InlSmall else InlVanilla - small = case calcUnfoldingGuidance (arity+1) expr' of - (arity_e, UnfoldIfGoodArgs { ug_size = size_e }) - -> uncondInline arity_e size_e - _other {- actually UnfoldNever -} -> False + boring_ok = case calcUnfoldingGuidance True -- Treat as cheap + (arity+1) expr' of + (_, UnfWhen _ boring_ok) -> boring_ok + _other -> boringCxtNotOk + -- See Note [INLINE for small functions] \end{code} @@ -149,25 +161,34 @@ mkInlineRule sat expr arity \begin{code} calcUnfoldingGuidance - :: Int -- bomb out if size gets bigger than this - -> CoreExpr -- expression to look at + :: Bool -- True <=> the rhs is cheap, or we want to treat it + -- as cheap (INLINE things) + -> Int -- Bomb out if size gets bigger than this + -> CoreExpr -- Expression to look at -> (Arity, UnfoldingGuidance) -calcUnfoldingGuidance bOMB_OUT_SIZE expr - = case collectBinders expr of { (binders, body) -> +calcUnfoldingGuidance expr_is_cheap bOMB_OUT_SIZE expr + = case collectBinders expr of { (bndrs, body) -> let - val_binders = filter isId binders - n_val_binders = length val_binders + val_bndrs = filter isId bndrs + n_val_bndrs = length val_bndrs + + guidance + = case (sizeExpr (iUnbox bOMB_OUT_SIZE) val_bndrs body) of + TooBig -> UnfNever + SizeIs size cased_bndrs scrut_discount + | uncondInline n_val_bndrs (iBox size) && expr_is_cheap + -> UnfWhen needSaturated boringCxtOk + + | otherwise + -> UnfIfGoodArgs { ug_args = map (discount cased_bndrs) val_bndrs + , ug_size = iBox size + , ug_res = iBox scrut_discount } + + discount cbs bndr + = foldlBag (\acc (b',n) -> if bndr==b' then acc+n else acc) + 0 cbs in - case (sizeExpr (iUnbox bOMB_OUT_SIZE) val_binders body) of - TooBig -> (n_val_binders, UnfoldNever) - SizeIs size cased_args scrut_discount - -> (n_val_binders, UnfoldIfGoodArgs { ug_args = map discount_for val_binders - , ug_size = iBox size - , ug_res = iBox scrut_discount }) - where - discount_for b = foldlBag (\acc (b',n) -> if b==b' then acc+n else acc) - 0 cased_args - } + (n_val_bndrs, guidance) } \end{code} Note [Computing the size of an expression] @@ -267,7 +288,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr size_up (Case (Var v) _ _ alts) | v `elem` top_args -- We are scrutinising an argument variable - = alts_size (foldr addSize sizeOne alt_sizes) -- The 1 is for the case itself + = alts_size (foldr1 addSize alt_sizes) -- The 1 is for the case itself (foldr1 maxSize alt_sizes) -- Good to inline if an arg is scrutinised, because -- that may eliminate allocation in the caller @@ -279,7 +300,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr -- the case when we are scrutinising an argument variable alts_size (SizeIs tot tot_disc _tot_scrut) -- Size of all alternatives (SizeIs max _max_disc max_scrut) -- Size of biggest alternative - = SizeIs tot (unitBag (v, iBox (_ILIT(1) +# tot -# max)) `unionBags` tot_disc) max_scrut + = SizeIs tot (unitBag (v, iBox (_ILIT(2) +# tot -# max)) `unionBags` tot_disc) max_scrut -- If the variable is known, we produce a discount that -- will take us back to 'max', the size of the largest alternative -- The 1+ is a little discount for reduced allocation in the caller @@ -292,12 +313,13 @@ sizeExpr bOMB_OUT_SIZE top_args expr size_up (Case e _ _ alts) = foldr (addSize . size_up_alt) (nukeScrutDiscount (size_up e)) alts - `addSizeN` 1 -- Add 1 for the case itself -- We don't charge for the case itself -- It's a strict thing, and the price of the call -- is paid by scrut. Also consider -- case f x of DEFAULT -> e -- This is just ';'! Don't charge for it. + -- + -- Moreover, we charge one per alternative. ------------ -- size_up_app is used when there's ONE OR MORE value args @@ -522,17 +544,14 @@ maxSize _ TooBig = TooBig maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2 = s1 | otherwise = s2 -sizeZero, sizeOne :: ExprSize +sizeZero :: ExprSize sizeN :: Int -> ExprSize sizeZero = SizeIs (_ILIT(0)) emptyBag (_ILIT(0)) -sizeOne = SizeIs (_ILIT(1)) emptyBag (_ILIT(0)) sizeN n = SizeIs (iUnbox n) emptyBag (_ILIT(0)) \end{code} - - %************************************************************************ %* * \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding} @@ -547,13 +566,13 @@ actual arguments. \begin{code} couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool couldBeSmallEnoughToInline threshold rhs - = case calcUnfoldingGuidance threshold rhs of - (_, UnfoldNever) -> False - _ -> True + = case calcUnfoldingGuidance False threshold rhs of + (_, UnfNever) -> False + _ -> True ---------------- smallEnoughToInline :: Unfolding -> Bool -smallEnoughToInline (CoreUnfolding {uf_guidance = UnfoldIfGoodArgs {ug_size = size}}) +smallEnoughToInline (CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_size = size}}) = size <= opt_UF_UseThreshold smallEnoughToInline _ = False @@ -563,9 +582,9 @@ certainlyWillInline :: Unfolding -> Bool -- Sees if the unfolding is pretty certain to inline certainlyWillInline (CoreUnfolding { uf_is_cheap = is_cheap, uf_arity = n_vals, uf_guidance = guidance }) = case guidance of - UnfoldNever -> False - InlineRule {} -> True - UnfoldIfGoodArgs { ug_size = size} + UnfNever -> False + UnfWhen {} -> True + UnfIfGoodArgs { ug_size = size} -> is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold certainlyWillInline _ @@ -596,8 +615,8 @@ StrictAnal.addStrictnessInfoToTopId \begin{code} callSiteInline :: DynFlags - -> Bool -- True <=> the Id can be inlined -> Id -- The Id + -> Unfolding -- Its unfolding (if active) -> Bool -- True if there are are no arguments at all (incl type args) -> [ArgSummary] -- One for each value arg; True if it is interesting -> CallCtxt -- True <=> continuation is interesting @@ -632,8 +651,8 @@ instance Outputable CallCtxt where ppr CaseCtxt = ptext (sLit "CaseCtxt") ppr ValAppCtxt = ptext (sLit "ValAppCtxt") -callSiteInline dflags active_inline id lone_variable arg_infos cont_info - = case idUnfolding id of { +callSiteInline dflags id unfolding lone_variable arg_infos cont_info + = case unfolding of { NoUnfolding -> Nothing ; OtherCon _ -> Nothing ; DFunUnfolding {} -> Nothing ; -- Never unfold a DFun @@ -642,7 +661,8 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info -- uf_arity will typically be equal to (idArity id), -- but may be less for InlineRules let - n_val_args = length arg_infos + n_val_args = length arg_infos + saturated = n_val_args >= uf_arity result | yes_or_no = Just unf_template | otherwise = Nothing @@ -657,9 +677,12 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info -- arguments (ie n_val_args >= arity). But there must -- be *something* interesting about some argument, or the -- result context, to make it worth inlining - some_benefit = interesting_args - || n_val_args > uf_arity -- Over-saturated - || interesting_saturated_call -- Exactly saturated + some_benefit + | not saturated = interesting_args -- Under-saturated + -- Note [Unsaturated applications] + | n_val_args > uf_arity = True -- Over-saturated + | otherwise = interesting_args -- Saturated + || interesting_saturated_call interesting_saturated_call = case cont_info of @@ -668,46 +691,35 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info ArgCtxt {} -> uf_arity > 0 -- Note [Inlining in ArgCtxt] ValAppCtxt -> True -- Note [Cast then apply] - yes_or_no + (yes_or_no, extra_doc) = case guidance of - UnfoldNever -> False - - InlineRule { ir_info = inl_info, ir_sat = sat } - | InlAlways <- inl_info -> True -- No top-level binding, so inline! - -- Ignore is_active because we want to - -- inline even if SimplGently is on. - | not active_inline -> False - | n_val_args < uf_arity -> yes_unsat -- Not enough value args - | InlSmall <- inl_info -> True -- Note [INLINE for small functions] - | otherwise -> some_benefit -- Saturated or over-saturated - where - -- See Note [Inlining an InlineRule] - yes_unsat = case sat of - InlSat -> False - InlUnSat -> interesting_args - - UnfoldIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size } - | not active_inline -> False - | not is_cheap -> False - | n_val_args < uf_arity -> interesting_args && small_enough - -- Note [Unsaturated applications] - | uncondInline uf_arity size -> True - | otherwise -> some_benefit && small_enough + UnfNever -> (False, empty) + + UnfWhen unsat_ok boring_ok -> ( (unsat_ok || saturated) + && (boring_ok || some_benefit) + , empty ) + -- For the boring_ok part see Note [INLINE for small functions] + UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size } + -> ( is_cheap && some_benefit && small_enough + , (text "discounted size =" <+> int discounted_size) ) where - small_enough = (size - discount) <= opt_UF_UseThreshold + discounted_size = size - discount + small_enough = discounted_size <= opt_UF_UseThreshold discount = computeDiscount uf_arity arg_discounts res_discount arg_infos cont_info in if dopt Opt_D_dump_inlinings dflags then pprTrace ("Considering inlining: " ++ showSDoc (ppr id)) - (vcat [text "active:" <+> ppr active_inline, - text "arg infos" <+> ppr arg_infos, + (vcat [text "arg infos" <+> ppr arg_infos, + text "uf arity" <+> ppr uf_arity, text "interesting continuation" <+> ppr cont_info, + text "some_benefit" <+> ppr some_benefit, text "is value:" <+> ppr is_value, text "is cheap:" <+> ppr is_cheap, text "guidance" <+> ppr guidance, + extra_doc, text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"]) result else @@ -759,7 +771,7 @@ Consider {-# INLINE f #-} g y = f y Then f's RHS is no larger than its LHS, so we should inline it into even the most boring context. (We do so if there is no INLINE -pragma!) That's the reason for the 'ug_small' flag on an InlineRule. +pragma!) Note [Things to watch] @@ -776,7 +788,7 @@ Note [Things to watch] Note [Inlining an InlineRule] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ An InlineRules is used for - (a) pogrammer INLINE pragmas + (a) programmer INLINE pragmas (b) inlinings from worker/wrapper For (a) the RHS may be large, and our contract is that we *only* inline @@ -1025,17 +1037,17 @@ However e might not *look* as if -- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is -- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@, -- where t1..tk are the *universally-qantified* type args of 'dc' -exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [Type], [CoreExpr]) +exprIsConApp_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr]) -exprIsConApp_maybe (Note _ expr) - = exprIsConApp_maybe expr +exprIsConApp_maybe id_unf (Note _ expr) + = exprIsConApp_maybe id_unf expr -- We ignore all notes. For example, -- case _scc_ "foo" (C a b) of -- C a b -> e -- should be optimised away, but it will be only if we look -- through the SCC note. -exprIsConApp_maybe (Cast expr co) +exprIsConApp_maybe id_unf (Cast expr co) = -- Here we do the KPush reduction rule as described in the FC paper -- The transformation applies iff we have -- (C e1 ... en) `cast` co @@ -1043,7 +1055,7 @@ exprIsConApp_maybe (Cast expr co) -- The left-hand one must be a T, because exprIsConApp returned True -- but the right-hand one might not be. (Though it usually will.) - case exprIsConApp_maybe expr of { + case exprIsConApp_maybe id_unf expr of { Nothing -> Nothing ; Just (dc, _dc_univ_args, dc_args) -> @@ -1104,7 +1116,7 @@ exprIsConApp_maybe (Cast expr co) Just (dc, to_tc_arg_tys, ex_args ++ new_co_args ++ new_val_args) }} -exprIsConApp_maybe expr +exprIsConApp_maybe id_unf expr = analyse expr [] where analyse (App fun arg) args = analyse fun (arg:args) @@ -1131,7 +1143,7 @@ exprIsConApp_maybe expr analyse rhs args where is_saturated = count isValArg args == idArity fun - unfolding = idUnfolding fun -- Does not look through loop breakers + unfolding = id_unf fun -- Does not look through loop breakers -- ToDo: we *may* look through variables that are NOINLINE -- in this phase, and that is really not right diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 9761db1..1590978 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -27,7 +27,7 @@ module CoreUtils ( exprType, coreAltType, coreAltsType, exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable, exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike, - rhsIsStatic, + rhsIsStatic, isCheapApp, isExpandableApp, -- * Expression and bindings size coreBindsSize, exprSize, @@ -61,6 +61,7 @@ import DataCon import PrimOp import Id import IdInfo +import TcType ( isPredTy ) import Type import Coercion import TyCon @@ -499,30 +500,37 @@ 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' :: (Id -> Bool) -> CoreExpr -> Bool -exprIsCheap' _ (Lit _) = True -exprIsCheap' _ (Type _) = True -exprIsCheap' _ (Var _) = 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] +exprIsCheap :: CoreExpr -> Bool +exprIsCheap = exprIsCheap' isCheapApp + +exprIsExpandable :: CoreExpr -> Bool +exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in BasicTypes + + +exprIsCheap' :: (Id -> Int -> Bool) -> CoreExpr -> Bool +exprIsCheap' _ (Lit _) = True +exprIsCheap' _ (Type _) = True +exprIsCheap' _ (Var _) = True +exprIsCheap' good_app (Note _ e) = exprIsCheap' good_app e +exprIsCheap' good_app (Cast e _) = exprIsCheap' good_app e +exprIsCheap' good_app (Lam x e) = isRuntimeVar x + || exprIsCheap' good_app e + +exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e && + and [exprIsCheap' good_app 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' is_conlike (Let (NonRec x _) e) - | isUnLiftedType (idType x) = exprIsCheap' is_conlike e +exprIsCheap' good_app (Let (NonRec x _) e) + | isUnLiftedType (idType x) = exprIsCheap' good_app e | otherwise = False -- Strict lets always have cheap right hand sides, -- and do no allocation, so just look at the body -- Non-strict lets do allocation so we don't treat them as cheap -exprIsCheap' is_conlike other_expr -- Applications and variables +exprIsCheap' good_app other_expr -- Applications and variables = go other_expr [] where -- Accumulate value arguments, then decide @@ -533,14 +541,12 @@ exprIsCheap' is_conlike other_expr -- Applications and variables -- (f t1 t2 t3) counts as WHNF go (Var f) args = case idDetails f of - RecSelId {} -> go_sel args - ClassOpId {} -> go_sel args - PrimOpId op -> go_primop op args - - _ | is_conlike f -> go_pap args - | length args < idArity f -> go_pap args - - _ -> isBottomingId f + RecSelId {} -> go_sel args + ClassOpId {} -> go_sel args + PrimOpId op -> go_primop op args + _ | good_app f (length args) -> go_pap args + | isBottomingId f -> True + | otherwise -> False -- Application of a function which -- always gives bottom; we treat this as cheap -- because it certainly doesn't need to be shared! @@ -555,26 +561,53 @@ exprIsCheap' is_conlike other_expr -- Applications and variables -- We'll put up with one constructor application, but not dozens -------------- - go_primop op args = primOpIsCheap op && all (exprIsCheap' is_conlike) args + go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) 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' is_conlike arg -- I'm experimenting with making record selection + go_sel [arg] = exprIsCheap' good_app 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 +isCheapApp :: Id -> Int -> Bool +isCheapApp fn n_val_args + = isDataConWorkId fn + || n_val_args < idArity fn -exprIsExpandable :: CoreExpr -> Bool -exprIsExpandable = exprIsCheap' isConLikeId -- See Note [CONLIKE pragma] in BasicTypes +isExpandableApp :: Id -> Int -> Bool +isExpandableApp fn n_val_args + = isConLikeId fn + || n_val_args < idArity fn + || go n_val_args (idType fn) + where + -- See if all the arguments are PredTys (implicit params or classes) + -- If so we'll regard it as expandable; see Note [Expandable overloadings] + go 0 _ = True + go n_val_args ty + | Just (_, ty) <- splitForAllTy_maybe ty = go n_val_args ty + | Just (arg, ty) <- splitFunTy_maybe ty + , isPredTy arg = go (n_val_args-1) ty + | otherwise = False \end{code} +Note [Expandable overloadings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose the user wrote this + {-# RULE forall x. foo (negate x) = h x #-} + f x = ....(foo (negate x)).... +He'd expect the rule to fire. But since negate is overloaded, we might +get this: + f = \d -> let n = negate d in \x -> ...foo (n x)... +So we treat the application of a function (negate in this case) to a +*dictionary* as expandable. In effect, every function is CONLIKE when +it's applied only to dictionaries. + + %************************************************************************ %* * exprOkForSpeculation diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 950e37b..4d828b6 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -370,37 +370,37 @@ showAttributes stuff \begin{code} instance Outputable UnfoldingGuidance where - ppr UnfoldNever = ptext (sLit "NEVER") - ppr (InlineRule { ir_info = info, ir_sat = sat }) - = ptext (sLit "InlineRule") <> ppr (sat,info) - ppr (UnfoldIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount }) + ppr UnfNever = ptext (sLit "NEVER") + ppr (UnfWhen sat_ok boring_ok) + = ptext (sLit "ALWAYS_IF") <> + parens (ptext (sLit "sat_ok=") <> ppr sat_ok <> comma <> + ptext (sLit "boring_ok=") <> ppr boring_ok) + ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount }) = hsep [ ptext (sLit "IF_ARGS"), brackets (hsep (map int cs)), int size, int discount ] -instance Outputable InlSatFlag where - ppr InlSat = ptext (sLit "sat") - ppr InlUnSat = ptext (sLit "unsat") - -instance Outputable InlineRuleInfo where - ppr (InlWrapper w) = ptext (sLit "worker=") <> ppr w - ppr InlSmall = ptext (sLit "small") - ppr InlAlways = ptext (sLit "always") - ppr InlVanilla = ptext (sLit "-") +instance Outputable UnfoldingSource where + ppr InlineCompulsory = ptext (sLit "Compulsory") + ppr (InlineWrapper w) = ptext (sLit "Worker=") <> ppr w + ppr InlineRule = ptext (sLit "InlineRule") + ppr InlineRhs = ptext (sLit "") instance Outputable Unfolding where ppr NoUnfolding = ptext (sLit "No unfolding") ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs ppr (DFunUnfolding con ops) = ptext (sLit "DFun") <+> ppr con <+> brackets (pprWithCommas pprParendExpr ops) - ppr (CoreUnfolding { uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf + ppr (CoreUnfolding { uf_src = src + , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf , uf_is_conlike=conlike, uf_is_cheap=cheap , uf_expandable=exp, uf_guidance=g, uf_arity=arity}) = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs) where pp_info = fsep $ punctuate comma - [ ptext (sLit "TopLvl=") <> ppr top + [ ptext (sLit "Src=") <> ppr src + , ptext (sLit "TopLvl=") <> ppr top , ptext (sLit "Arity=") <> int arity , ptext (sLit "Value=") <> ppr hnf , ptext (sLit "ConLike=") <> ppr conlike @@ -408,11 +408,8 @@ instance Outputable Unfolding where , ptext (sLit "Expandable=") <> ppr exp , ptext (sLit "Guidance=") <> ppr g ] pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs - pp_rhs = case g of - UnfoldNever -> usually_empty - UnfoldIfGoodArgs {} -> usually_empty - _other -> pp_tmpl - usually_empty = ifPprDebug (ptext (sLit "")) + pp_rhs | isInlineRuleSource src = pp_tmpl + | otherwise = empty -- Don't print the RHS or we get a quadratic -- blowup in the size of the printout! \end{code} diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 0bb7045..4a11ea2 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -322,7 +322,7 @@ makeCorePair gbl_id arity rhs | isInlinePragma (idInlinePragma gbl_id) -- Add an Unfolding for an INLINE (but not for NOINLINE) -- And eta-expand the RHS; see Note [Eta-expanding INLINE things] - = (gbl_id `setIdUnfolding` mkInlineRule InlSat rhs arity, + = (gbl_id `setIdUnfolding` mkInlineRule needSaturated rhs arity, etaExpand arity rhs) | otherwise = (gbl_id, rhs) @@ -406,22 +406,28 @@ dsSpecs :: [TyVar] -> [DictId] -> [TyVar] -> DsM ( [(Id,CoreExpr)] -- Binding for specialised Ids , [CoreRule] ) -- Rules for the Global Ids -- Example: --- f :: (Eq a, Ix b) => a -> b -> b --- {-# SPECIALISE f :: Ix b => Int -> b -> b #-} +-- f :: (Eq a, Ix b) => a -> b -> Bool +-- {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-} -- -- AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds -- --- SpecPrag (/\b.\(d:Ix b). f Int b dInt d) --- (forall b. Ix b => Int -> b -> b) +-- SpecPrag /\pq.\(dp:Ix p, dq:Ix q). f Int (p,q) dInt ($dfIxPair dp dq) +-- :: forall p q. (Ix p, Ix q) => Int -> (p,q) -> Bool -- --- Rule: forall b,(d:Ix b). f Int b dInt d = f_spec b d +-- +-- Rule: forall p,q,(dp:Ix p),(dq:Ix q). +-- f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq -- -- Spec bind: f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono --- /\b.\(d:Ix b). in f Int b dInt d +-- /\pq.\(dp:Ix p, dq:Ix q). f Int (p,q) dInt ($dfIxPair dp dq) -- The idea is that f occurs just once, so it'll be -- inlined and specialised -- --- Given SpecPrag (/\as.\ds. f es) t, we have +-- Note that the LHS of the rule may mention dictionary *expressions* +-- (eg $dfIxPair dp dq), and that is essential because +-- the dp, dq are needed on the RHS. +-- +-- In general, given SpecPrag (/\as.\ds. f es) t, we have -- the defn f_spec as ds = let-nonrec f = /\fas\fds. let f_mono = in f_mono -- in f es -- and the RULE forall as, ds. f es = f_spec as ds @@ -467,8 +473,8 @@ dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags spec_id_arity = inl_arity + count isDictId bndrs extra_dict_bndrs = [ localiseId d -- See Note [Constant rule dicts] - | d <- varSetElems (exprFreeVars ds_spec_expr) - , isDictId d] + | d <- varSetElems (exprFreeVars ds_spec_expr) + , isDictId d] -- Note [Const rule dicts] rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name))) diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 5340039..fa57d41 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -207,7 +207,7 @@ dsFCall fn_id fcall = do work_app = mkApps (mkVarApps (Var work_id) tvs) val_args wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers wrap_rhs = mkLams (tvs ++ args) wrapper_body - fn_id_w_inl = fn_id `setIdUnfolding` mkInlineRule InlSat wrap_rhs (length args) + fn_id_w_inl = fn_id `setIdUnfolding` mkInlineRule needSaturated wrap_rhs (length args) return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty) \end{code} diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index be68afe..9485dc9 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -212,7 +212,7 @@ data IfaceInfoItem data IfaceUnfolding = IfCoreUnfold IfaceExpr | IfInlineRule Arity - Bool -- Sat/UnSat + Bool -- OK to inline even if *un*-saturated IfaceExpr | IfWrapper Arity Name -- NB: we need a Name (not just OccName) because the worker -- can simplify to a function in another module. diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index cad384c..9282920 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1481,23 +1481,26 @@ toIfaceIdInfo id_info -------------------------- toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem -toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity, uf_guidance = guidance }) - = case guidance of - InlineRule { ir_info = InlWrapper w } -> Just (HsUnfold lb (IfWrapper arity (idName w))) - InlineRule { ir_sat = InlSat } -> Just (HsUnfold lb (IfInlineRule arity True (toIfaceExpr rhs))) - InlineRule { ir_sat = InlUnSat } -> Just (HsUnfold lb (IfInlineRule arity False (toIfaceExpr rhs))) - UnfoldIfGoodArgs {} -> vanilla_unfold - UnfoldNever -> vanilla_unfold -- Yes, even if guidance is UnfoldNever, expose the unfolding - -- If we didn't want to expose the unfolding, TidyPgm would - -- have stuck in NoUnfolding. For supercompilation we want - -- to see that unfolding! +toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity + , uf_src = src, uf_guidance = guidance }) + = case src of + InlineWrapper w -> Just (HsUnfold lb (IfWrapper arity (idName w))) + InlineRule {} -> Just (HsUnfold lb (IfInlineRule arity sat (toIfaceExpr rhs))) + _other -> Just (HsUnfold lb (IfCoreUnfold (toIfaceExpr rhs))) + -- Yes, even if guidance is UnfNever, expose the unfolding + -- If we didn't want to expose the unfolding, TidyPgm would + -- have stuck in NoUnfolding. For supercompilation we want + -- to see that unfolding! where - vanilla_unfold = Just (HsUnfold lb (IfCoreUnfold (toIfaceExpr rhs))) + sat = case guidance of + UnfWhen unsat_ok _ -> unsat_ok + _other -> needSaturated toIfUnfolding lb (DFunUnfolding _con ops) = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops))) -- No need to serialise the data constructor; -- we can recover it from the type of the dfun + toIfUnfolding _ _ = Nothing diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index cecfc0b..2ec9de9 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -1009,14 +1009,11 @@ tcUnfolding name _ _ (IfCoreUnfold if_expr) Nothing -> NoUnfolding Just expr -> mkTopUnfolding expr) } -tcUnfolding name _ _ (IfInlineRule arity sat if_expr) +tcUnfolding name _ _ (IfInlineRule arity unsat_ok if_expr) = do { mb_expr <- tcPragExpr name if_expr ; return (case mb_expr of Nothing -> NoUnfolding - Just expr -> mkInlineRule inl_info expr arity) } - where - inl_info | sat = InlSat - | otherwise = InlUnSat + Just expr -> mkInlineRule unsat_ok expr arity) } tcUnfolding name ty info (IfWrapper arity wkr) = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index ab09f62..8e17328 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -82,6 +82,7 @@ import Maybes ( orElse ) import SrcLoc import FastString import FiniteMap +import BasicTypes ( CompilerPhase ) import Outputable import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage ) @@ -998,8 +999,8 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoOldStrictness | CoreDoGlomBinds | CoreCSE - | CoreDoRuleCheck Int{-CompilerPhase-} String -- Check for non-application of rules - -- matching this string + | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules + -- matching this string | CoreDoVectorisation PackageId | CoreDoNothing -- Useful when building up | CoreDoPasses [CoreToDo] -- lists of these things diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 8f3a520..6a9f0dd 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -1064,19 +1064,19 @@ tidyTopIdInfo is_external idinfo unfold_info arity caf_info occ_info ------------ Unfolding -------------- tidyUnfolding :: TidyEnv -> CoreExpr -> Unfolding -> Unfolding -tidyUnfolding tidy_env _ unf@(CoreUnfolding { uf_tmpl = rhs - , uf_guidance = guide@(InlineRule {}) }) - = unf { uf_tmpl = tidyExpr tidy_env rhs, -- Preserves OccInfo - uf_guidance = guide { ir_info = tidyInl tidy_env (ir_info guide) } } tidyUnfolding tidy_env _ (DFunUnfolding con ids) = DFunUnfolding con (map (tidyExpr tidy_env) ids) -tidyUnfolding _ tidy_rhs (CoreUnfolding {}) +tidyUnfolding tidy_env tidy_rhs unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) + | isInlineRuleSource src + = unf { uf_tmpl = tidyExpr tidy_env unf_rhs, -- Preserves OccInfo + uf_src = tidyInl tidy_env src } + | otherwise = mkTopUnfolding tidy_rhs tidyUnfolding _ _ unf = unf -tidyInl :: TidyEnv -> InlineRuleInfo -> InlineRuleInfo -tidyInl tidy_env (InlWrapper w) = InlWrapper (tidyVarOcc tidy_env w) -tidyInl _ inl_info = inl_info +tidyInl :: TidyEnv -> UnfoldingSource -> UnfoldingSource +tidyInl tidy_env (InlineWrapper w) = InlineWrapper (tidyVarOcc tidy_env w) +tidyInl _ inl_info = inl_info \end{code} %************************************************************************ diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 1515fb9..bc8c9b8 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -339,9 +339,9 @@ litEq op_name is_eq ru_fn = op_name, ru_nargs = 2, ru_try = rule_fn }] where - rule_fn [Lit lit, expr] = do_lit_eq lit expr - rule_fn [expr, Lit lit] = do_lit_eq lit expr - rule_fn _ = Nothing + rule_fn _ [Lit lit, expr] = do_lit_eq lit expr + rule_fn _ [expr, Lit lit] = do_lit_eq lit expr + rule_fn _ _ = Nothing do_lit_eq lit expr = Just (mkWildCase expr (literalType lit) boolTy @@ -374,7 +374,9 @@ wordResult result %************************************************************************ \begin{code} -mkBasicRule :: Name -> Int -> ([CoreExpr] -> Maybe CoreExpr) -> [CoreRule] +mkBasicRule :: Name -> Int + -> (IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr) + -> [CoreRule] -- Gives the Rule the same name as the primop itself mkBasicRule op_name n_args rule_fn = [BuiltinRule { ru_name = occNameFS (nameOccName op_name), @@ -386,16 +388,16 @@ oneLit :: Name -> (Literal -> Maybe CoreExpr) oneLit op_name test = mkBasicRule op_name 1 rule_fn where - rule_fn [Lit l1] = test (convFloating l1) - rule_fn _ = Nothing + rule_fn _ [Lit l1] = test (convFloating l1) + rule_fn _ _ = Nothing twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr) -> [CoreRule] twoLits op_name test = mkBasicRule op_name 2 rule_fn where - rule_fn [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2) - rule_fn _ = Nothing + rule_fn _ [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2) + rule_fn _ _ = Nothing -- When excess precision is not requested, cut down the precision of the -- Rational value to that of Float/Double. We confuse host architecture @@ -428,8 +430,8 @@ mkDoubleVal d = Lit (convFloating (MachDouble d)) %************************************************************************ \begin{code} -tagToEnumRule :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -tagToEnumRule [Type ty, Lit (MachInt i)] +tagToEnumRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) +tagToEnumRule _ [Type ty, Lit (MachInt i)] = ASSERT( isEnumerationTyCon tycon ) case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of @@ -442,7 +444,7 @@ tagToEnumRule [Type ty, Lit (MachInt i)] tag = fromInteger i tycon = tyConAppTyCon ty -tagToEnumRule _ = Nothing +tagToEnumRule _ _ = Nothing \end{code} For dataToTag#, we can reduce if either @@ -451,18 +453,18 @@ For dataToTag#, we can reduce if either (b) the argument is a variable whose unfolding is a known constructor \begin{code} -dataToTagRule :: [Expr CoreBndr] -> Maybe (Arg CoreBndr) -dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] +dataToTagRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Arg CoreBndr) +dataToTagRule _ [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] | tag_to_enum `hasKey` tagToEnumKey , ty1 `coreEqType` ty2 = Just tag -- dataToTag (tagToEnum x) ==> x -dataToTagRule [_, val_arg] - | Just (dc,_,_) <- exprIsConApp_maybe val_arg +dataToTagRule id_unf [_, val_arg] + | Just (dc,_,_) <- exprIsConApp_maybe id_unf val_arg = ASSERT( not (isNewTyCon (dataConTyCon dc)) ) Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG))) -dataToTagRule _ = Nothing +dataToTagRule _ _ = Nothing \end{code} %************************************************************************ @@ -515,15 +517,15 @@ builtinRules -- The rule is this: -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n -match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_append_lit [Type ty1, - Lit (MachStr s1), - c1, - Var unpk `App` Type ty2 - `App` Lit (MachStr s2) - `App` c2 - `App` n - ] +match_append_lit :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_append_lit _ [Type ty1, + Lit (MachStr s1), + c1, + Var unpk `App` Type ty2 + `App` Lit (MachStr s2) + `App` c2 + `App` n + ] | unpk `hasKey` unpackCStringFoldrIdKey && c1 `cheapEqExpr` c2 = ASSERT( ty1 `coreEqType` ty2 ) @@ -532,20 +534,20 @@ match_append_lit [Type ty1, `App` c1 `App` n) -match_append_lit _ = Nothing +match_append_lit _ _ = Nothing --------------------------------------------------- -- The rule is this: -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2 -match_eq_string :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_eq_string [Var unpk1 `App` Lit (MachStr s1), - Var unpk2 `App` Lit (MachStr s2)] +match_eq_string :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_eq_string _ [Var unpk1 `App` Lit (MachStr s1), + Var unpk2 `App` Lit (MachStr s2)] | unpk1 `hasKey` unpackCStringIdKey, unpk2 `hasKey` unpackCStringIdKey = Just (if s1 == s2 then trueVal else falseVal) -match_eq_string _ = Nothing +match_eq_string _ _ = Nothing --------------------------------------------------- @@ -561,11 +563,12 @@ match_eq_string _ = Nothing -- programmer can't avoid -- -- Also, don't forget about 'inline's type argument! -match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_inline (Type _ : e : _) +match_inline :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_inline _ (Type _ : e : _) | (Var f, args1) <- collectArgs e, Just unf <- maybeUnfoldingTemplate (realIdUnfolding f) + -- Ignore the IdUnfoldingFun here! = Just (mkApps unf args1) -match_inline _ = Nothing +match_inline _ _ = Nothing \end{code} diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 5824874..2199ab1 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -20,7 +20,7 @@ module OccurAnal ( import CoreSyn import CoreFVs import Type ( tyVarsOfType ) -import CoreUtils ( exprIsTrivial, isDefaultAlt, mkCoerceI ) +import CoreUtils ( exprIsTrivial, isDefaultAlt, mkCoerceI, isExpandableApp ) import Coercion ( CoercionI(..), mkSymCoI ) import Id import Name ( localiseName ) @@ -532,11 +532,11 @@ reOrderCycle depth (bind : binds) pairs | isDFunId bndr = 9 -- Never choose a DFun as a loop breaker -- Note [DFuns should not be loop breakers] - | Just (inl_rule_info, _) <- isInlineRule_maybe (idUnfolding bndr) - = case inl_rule_info of - InlWrapper {} -> 10 -- Note [INLINE pragmas] - _other -> 3 -- Data structures are more important than this - -- so that dictionary/method recursion unravels + | Just (inl_source, _) <- isInlineRule_maybe (idUnfolding bndr) + = case inl_source of + InlineWrapper {} -> 10 -- Note [INLINE pragmas] + _other -> 3 -- Data structures are more important than this + -- so that dictionary/method recursion unravels -- Note that this case hits all InlineRule things, so we -- never look at 'rhs for InlineRule stuff. That's right, because -- 'rhs' is irrelevant for inlining things with an InlineRule @@ -940,14 +940,16 @@ occAnalApp :: OccEnv occAnalApp env (Var fun, args) = case args_stuff of { (args_uds, args') -> let - final_args_uds = markRhsUds env is_pap args_uds + final_args_uds = markRhsUds env is_exp args_uds in (fun_uds +++ final_args_uds, mkApps (Var fun) args') } where fun_uniq = idUnique fun fun_uds = mkOneOcc env fun (valArgCount args > 0) - is_pap = isConLikeId fun || valArgCount args < idArity fun + is_exp = isExpandableApp fun (valArgCount args) -- See Note [CONLIKE pragma] in BasicTypes + -- The definition of is_exp should match that in + -- Simplify.prepareRhs -- Hack for build, fold, runST args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index beb1ed0..5dfd40b 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -225,11 +225,10 @@ printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds) ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts ruleCheck current_phase pat guts = do - let is_active = isActive current_phase rb <- getRuleBase dflags <- getDynFlags liftIO $ Err.showPass dflags "RuleCheck" - liftIO $ printDump (ruleCheckProgram is_active pat rb (mg_binds guts)) + liftIO $ printDump (ruleCheckProgram current_phase pat rb (mg_binds guts)) return guts diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 87db9a8..7a5b96b 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -10,7 +10,7 @@ module SimplUtils ( -- Inlining, preInlineUnconditionally, postInlineUnconditionally, - activeInline, activeRule, + activeUnfolding, activeUnfInRule, activeRule, simplEnvForGHCi, simplEnvForRules, updModeForInlineRules, -- The continuation type @@ -334,7 +334,7 @@ mkArgInfo fun rules n_val_args call_cont vanilla_discounts, arg_discounts :: [Int] vanilla_discounts = repeat 0 arg_discounts = case idUnfolding fun of - CoreUnfolding {uf_guidance = UnfoldIfGoodArgs {ug_args = discounts}} + CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}} -> discounts ++ vanilla_discounts _ -> vanilla_discounts @@ -739,12 +739,12 @@ postInlineUnconditionally -> Unfolding -> Bool postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding - | not active = False - | isLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline + | not active = False + | isLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline -- because it might be referred to "earlier" - | isExportedId bndr = False - | isInlineRule unfolding = False -- Note [InlineRule and postInlineUnconditionally] - | exprIsTrivial rhs = True + | isExportedId bndr = False + | isStableUnfolding unfolding = False -- Note [InlineRule and postInlineUnconditionally] + | exprIsTrivial rhs = True | otherwise = case occ_info of -- The point of examining occ_info here is that for *non-values* @@ -757,7 +757,8 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding -- case v of -- True -> case x of ... -- False -> case x of ... - -- I'm not sure how important this is in practice + -- This is very important in practice; e.g. wheel-seive1 doubles + -- in allocation if you miss this out OneOcc in_lam _one_br int_cxt -- OneOcc => no code-duplication issue -> smallEnoughToInline unfolding -- Small enough to dup -- ToDo: consider discount on smallEnoughToInline if int_cxt is true @@ -810,27 +811,56 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding SimplPhase n _ -> isActive n act act = idInlineActivation bndr -activeInline :: SimplEnv -> OutId -> Bool -activeInline env id - | isNonRuleLoopBreaker (idOccInfo id) -- Things with an INLINE pragma may have - -- an unfolding *and* be a loop breaker - = False -- (maybe the knot is not yet untied) - | otherwise +activeUnfolding :: SimplEnv -> IdUnfoldingFun +activeUnfolding env + = case getMode env of + SimplGently { sm_inline = False } -> active_unfolding_minimal + SimplGently { sm_inline = True } -> active_unfolding_gentle + SimplPhase n _ -> active_unfolding n + +activeUnfInRule :: SimplEnv -> IdUnfoldingFun +-- When matching in RULE, we want to "look through" an unfolding +-- if *rules* are on, even if *inlinings* are not. A notable example +-- is DFuns, which really we want to match in rules like (op dfun) +-- in gentle mode. +activeUnfInRule env = case getMode env of - SimplGently { sm_inline = inlining_on } - -> inlining_on && isEarlyActive act - -- See Note [Gentle mode] - - -- NB: we used to have a second exception, for data con wrappers. - -- On the grounds that we use gentle mode for rule LHSs, and - -- they match better when data con wrappers are inlined. - -- But that only really applies to the trivial wrappers (like (:)), - -- and they are now constructed as Compulsory unfoldings (in MkId) - -- so they'll happen anyway. - - SimplPhase n _ -> isActive n act + SimplGently { sm_rules = False } -> active_unfolding_minimal + SimplGently { sm_rules = True } -> active_unfolding_gentle + SimplPhase n _ -> active_unfolding n + +active_unfolding_minimal :: IdUnfoldingFun +-- Compuslory unfoldings only +-- Ignore SimplGently, because we want to inline regardless; +-- the Id has no top-level binding at all +-- +-- NB: we used to have a second exception, for data con wrappers. +-- On the grounds that we use gentle mode for rule LHSs, and +-- they match better when data con wrappers are inlined. +-- But that only really applies to the trivial wrappers (like (:)), +-- and they are now constructed as Compulsory unfoldings (in MkId) +-- so they'll happen anyway. +active_unfolding_minimal id + | isCompulsoryUnfolding unf = unf + | otherwise = NoUnfolding where - act = idInlineActivation id + unf = realIdUnfolding id -- Never a loop breaker + +active_unfolding_gentle :: IdUnfoldingFun +-- Anything that is early-active +-- See Note [Gentle mode] +active_unfolding_gentle id + | isEarlyActive (idInlineActivation id) = idUnfolding id + | otherwise = NoUnfolding + -- idUnfolding checks for loop-breakers + -- Things with an INLINE pragma may have + -- an unfolding *and* be a loop breaker + -- (maybe the knot is not yet untied) + +active_unfolding :: CompilerPhase -> IdUnfoldingFun +active_unfolding n id + | isActive n (idInlineActivation id) = idUnfolding id + | otherwise = NoUnfolding activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool) -- Nothing => No rules at all diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 875061d..37fa798 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -447,28 +447,29 @@ prepareRhs env id (Cast rhs co) -- Note [Float coercions] info = idInfo id prepareRhs env0 _ rhs0 - = do { (_is_val, env1, rhs1) <- go 0 env0 rhs0 + = do { (_is_exp, env1, rhs1) <- go 0 env0 rhs0 ; return (env1, rhs1) } where go n_val_args env (Cast rhs co) - = do { (is_val, env', rhs') <- go n_val_args env rhs - ; return (is_val, env', Cast rhs' co) } + = do { (is_exp, env', rhs') <- go n_val_args env rhs + ; return (is_exp, env', Cast rhs' co) } go n_val_args env (App fun (Type ty)) - = do { (is_val, env', rhs') <- go n_val_args env fun - ; return (is_val, env', App rhs' (Type ty)) } + = do { (is_exp, env', rhs') <- go n_val_args env fun + ; return (is_exp, env', App rhs' (Type ty)) } go n_val_args env (App fun arg) - = do { (is_val, env', fun') <- go (n_val_args+1) env fun - ; case is_val of + = do { (is_exp, env', fun') <- go (n_val_args+1) env fun + ; case is_exp of True -> do { (env'', arg') <- makeTrivial env' arg ; return (True, env'', App fun' arg') } False -> return (False, env, App fun arg) } go n_val_args env (Var fun) - = return (is_val, env, Var fun) + = return (is_exp, env, Var fun) where - is_val = n_val_args > 0 -- There is at least one arg - -- ...and the fun a constructor or PAP - && (isConLikeId fun || n_val_args < idArity fun) - -- See Note [CONLIKE pragma] in BasicTypes + is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP + -- See Note [CONLIKE pragma] in BasicTypes + -- The definition of is_exp should match that in + -- OccurAnal.occAnalApp + go _ env other = return (False, env, other) \end{code} @@ -596,7 +597,8 @@ completeBind env top_lvl old_bndr new_bndr new_rhs ; if postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs new_unfolding -- Inline and discard the binding then do { tick (PostInlineUnconditionally old_bndr) - ; return (extendIdSubst env old_bndr (DoneEx new_rhs)) } + ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> equals <+> ppr new_rhs) $ + return (extendIdSubst env old_bndr (DoneEx new_rhs)) } -- Use the substitution to make quite, quite sure that the -- substitution will happen, since we are going to discard the binding @@ -671,12 +673,12 @@ simplUnfolding env _ _ _ _ (DFunUnfolding con ops) simplUnfolding env top_lvl _ _ _ (CoreUnfolding { uf_tmpl = expr, uf_arity = arity - , uf_guidance = guide@(InlineRule {}) }) + , uf_src = src, uf_guidance = guide }) + | isInlineRuleSource src = do { expr' <- simplExpr (updMode updModeForInlineRules env) expr -- See Note [Simplifying gently inside InlineRules] in SimplUtils - ; let mb_wkr' = CoreSubst.substInlineRuleInfo (mkCoreSubst env) (ir_info guide) - ; return (mkCoreUnfolding (isTopLevel top_lvl) expr' arity - (guide { ir_info = mb_wkr' })) } + ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst env) src + ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) } -- See Note [Top-level flag on inline rules] in CoreUnfold simplUnfolding _ top_lvl _ _occ_info new_rhs _ @@ -1122,9 +1124,9 @@ completeCall env var cont arg_infos = [interestingArg arg | arg <- args, isValArg arg] n_val_args = length arg_infos interesting_cont = interestingCallContext call_cont - active_inline = activeInline env var - maybe_inline = callSiteInline dflags active_inline var - (null args) arg_infos interesting_cont + unfolding = activeUnfolding env var + maybe_inline = callSiteInline dflags var unfolding + (null args) arg_infos interesting_cont ; case maybe_inline of { Just unfolding -- There is an inlining! -> do { tick (UnfoldingDone var) @@ -1267,7 +1269,7 @@ tryRules env rules fn args call_cont ; case activeRule dflags env of { Nothing -> return Nothing ; -- No rules apply Just act_fn -> - case lookupRule act_fn (getInScope env) fn args rules of { + case lookupRule act_fn (activeUnfInRule env) (getInScope env) fn args rules of { Nothing -> return Nothing ; -- No rule matches Just (rule, rule_rhs) -> @@ -1414,7 +1416,7 @@ rebuildCase env scrut case_bndr alts cont Nothing -> missingAlt env case_bndr alts cont Just (_, bs, rhs) -> simple_rhs bs rhs } - | Just (con, ty_args, other_args) <- exprIsConApp_maybe scrut + | Just (con, ty_args, other_args) <- exprIsConApp_maybe (activeUnfInRule env) scrut -- Works when the scrutinee is a variable with a known unfolding -- as well as when it's an explicit constructor application = do { tick (KnownBranch case_bndr) @@ -1946,7 +1948,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') DataAlt dc -> setIdUnfolding case_bndr unf where -- See Note [Case binders and join points] - unf = mkInlineRule InlSat rhs 0 + unf = mkInlineRule needSaturated rhs 0 rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty) ++ varsToCoreExprs bndrs') diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index cc5054a..90485d0 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -22,7 +22,7 @@ module Rules ( addIdSpecialisations, -- * Misc. CoreRule helpers - rulesOfBinds, getRules, pprRulesForUser, expandId, + rulesOfBinds, getRules, pprRulesForUser, lookupRule, mkRule, mkLocalRule, roughTopNames ) where @@ -45,7 +45,7 @@ import VarSet import Name ( Name, NamedThing(..) ) import NameEnv import Unify ( ruleMatchTyX, MatchEnv(..) ) -import BasicTypes ( Activation ) +import BasicTypes ( Activation, CompilerPhase, isActive ) import StaticFlags ( opt_PprStyle_Debug ) import Outputable import FastString @@ -288,13 +288,15 @@ to lookupRule are the result of a lazy substitution -- supplied rules to this instance of an application in a given -- context, returning the rule applied and the resulting expression if -- successful. -lookupRule :: (Activation -> Bool) -> InScopeSet +lookupRule :: (Activation -> Bool) -- When rule is active + -> IdUnfoldingFun -- When Id can be unfolded + -> InScopeSet -> Id -> [CoreExpr] -> [CoreRule] -> Maybe (CoreRule, CoreExpr) -- See Note [Extra args in rule matching] -- See comments on matchRule -lookupRule is_active in_scope fn args rules +lookupRule is_active id_unf in_scope fn args rules = -- pprTrace "matchRules" (ppr fn <+> ppr rules) $ case go [] rules of [] -> Nothing @@ -304,7 +306,7 @@ lookupRule is_active in_scope fn args rules go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] go ms [] = ms - go ms (r:rs) = case (matchRule is_active in_scope args rough_args r) of + go ms (r:rs) = case (matchRule is_active id_unf in_scope args rough_args r) of Just e -> go ((r,e):ms) rs Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$ -- ppr [(arg_id, unfoldingTemplate unf) | Var arg_id <- args, let unf = idUnfolding arg_id, isCheapUnfolding unf] ) @@ -339,8 +341,9 @@ isMoreSpecific (BuiltinRule {}) _ = True isMoreSpecific _ (BuiltinRule {}) = False isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 }) (Rule { ru_bndrs = bndrs2, ru_args = args2 }) - = isJust (matchN in_scope bndrs2 args2 args1) + = isJust (matchN id_unfolding_fun in_scope bndrs2 args2 args1) where + id_unfolding_fun _ = NoUnfolding -- Don't expand in templates in_scope = mkInScopeSet (mkVarSet bndrs1) -- Actually we should probably include the free vars -- of rule1's args, but I can't be bothered @@ -348,7 +351,8 @@ isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 }) noBlackList :: Activation -> Bool noBlackList _ = False -- Nothing is black listed -matchRule :: (Activation -> Bool) -> InScopeSet +matchRule :: (Activation -> Bool) -> IdUnfoldingFun + -> InScopeSet -> [CoreExpr] -> [Maybe Name] -> CoreRule -> Maybe CoreExpr @@ -374,21 +378,21 @@ matchRule :: (Activation -> Bool) -> InScopeSet -- Any 'surplus' arguments in the input are simply put on the end -- of the output. -matchRule _is_active _in_scope args _rough_args +matchRule _is_active id_unf _in_scope args _rough_args (BuiltinRule { ru_try = match_fn }) -- Built-in rules can't be switched off, it seems - = case match_fn args of + = case match_fn id_unf args of Just expr -> Just expr Nothing -> Nothing -matchRule is_active in_scope args rough_args +matchRule is_active id_unf in_scope args rough_args (Rule { ru_act = act, ru_rough = tpl_tops, ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) | not (is_active act) = Nothing | ruleCantMatch tpl_tops rough_args = Nothing | otherwise - = case matchN in_scope tpl_vars tpl_args args of + = case matchN id_unf in_scope tpl_vars tpl_args args of Nothing -> Nothing Just (binds, tpl_vals) -> Just (mkLets binds $ rule_fn `mkApps` tpl_vals) @@ -401,14 +405,15 @@ matchRule is_active in_scope args rough_args -- For a given match template and context, find bindings to wrap around -- the entire result and what should be substituted for each template variable. -- Fail if there are two few actual arguments from the target to match the template -matchN :: InScopeSet -- ^ In-scope variables +matchN :: IdUnfoldingFun + -> InScopeSet -- ^ In-scope variables -> [Var] -- ^ Match template type variables -> [CoreExpr] -- ^ Match template -> [CoreExpr] -- ^ Target; can have more elements than the template -> Maybe ([CoreBind], [CoreExpr]) -matchN in_scope tmpl_vars tmpl_es target_es +matchN id_unf in_scope tmpl_vars tmpl_es target_es = do { (tv_subst, id_subst, binds) <- go init_menv emptySubstEnv tmpl_es target_es ; return (fromOL binds, @@ -421,7 +426,7 @@ matchN in_scope tmpl_vars tmpl_es target_es go _ subst [] _ = Just subst go _ _ _ [] = Nothing -- Fail if too few actual args - go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e + go menv subst (t:ts) (e:es) = do { subst1 <- match id_unf menv subst t e ; go menv subst1 ts es } lookup_tmpl :: TvSubstEnv -> IdSubstEnv -> Var -> CoreExpr @@ -484,7 +489,8 @@ emptySubstEnv = (emptyVarEnv, emptyVarEnv, nilOL) -- SLPJ July 99 -match :: MatchEnv +match :: IdUnfoldingFun + -> MatchEnv -> SubstEnv -> CoreExpr -- Template -> CoreExpr -- Target @@ -506,19 +512,19 @@ match :: MatchEnv -- succeed in matching what looks like the template variable 'a' against 3. -- The Var case follows closely what happens in Unify.match -match menv subst (Var v1) e2 - | Just subst <- match_var menv subst v1 e2 +match idu menv subst (Var v1) e2 + | Just subst <- match_var idu menv subst v1 e2 = Just subst -match menv subst (Note _ e1) e2 = match menv subst e1 e2 -match menv subst e1 (Note _ e2) = match menv subst e1 e2 +match idu menv subst (Note _ e1) e2 = match idu menv subst e1 e2 +match idu menv subst e1 (Note _ e2) = match idu menv subst e1 e2 -- Ignore notes in both template and thing to be matched -- See Note [Notes in RULE matching] -match menv subst e1 (Var v2) -- Note [Expanding variables] +match id_unfolding_fun 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' + , Just e2' <- expandUnfolding (id_unfolding_fun v2') + = match id_unfolding_fun (menv { me_env = nukeRnEnvR rn_env }) subst e1 e2' where v2' = lookupRnInScope rn_env v2 rn_env = me_env menv @@ -527,10 +533,10 @@ match menv subst e1 (Var v2) -- Note [Expanding variables] -- 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) +match idu menv (tv_subst, id_subst, binds) e1 (Let bind e2) | all freshly_bound bndrs -- See Note [Matching lets] , not (any (locallyBoundR rn_env) bind_fvs) - = match (menv { me_env = rn_env' }) + = match idu (menv { me_env = rn_env' }) (tv_subst, id_subst, binds `snocOL` bind') e1 e2' where @@ -542,16 +548,16 @@ match menv (tv_subst, id_subst, binds) e1 (Let bind e2) e2' = e2 rn_env' = extendRnInScopeList rn_env bndrs -match _ subst (Lit lit1) (Lit lit2) +match _ _ subst (Lit lit1) (Lit lit2) | lit1 == lit2 = Just subst -match menv subst (App f1 a1) (App f2 a2) - = do { subst' <- match menv subst f1 f2 - ; match menv subst' a1 a2 } +match idu menv subst (App f1 a1) (App f2 a2) + = do { subst' <- match idu menv subst f1 f2 + ; match idu menv subst' a1 a2 } -match menv subst (Lam x1 e1) (Lam x2 e2) - = match menv' subst e1 e2 +match idu menv subst (Lam x1 e1) (Lam x2 e2) + = match idu menv' subst e1 e2 where menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 } @@ -560,45 +566,46 @@ match menv subst (Lam x1 e1) (Lam x2 e2) -- It's important that this is *after* the let rule, -- so that (\x.M) ~ (let y = e in \y.N) -- does the let thing, and then gets the lam/lam rule above -match menv subst (Lam x1 e1) e2 - = match menv' subst e1 (App e2 (varToCoreExpr new_x)) +match idu menv subst (Lam x1 e1) e2 + = match idu menv' subst e1 (App e2 (varToCoreExpr new_x)) where (rn_env', new_x) = rnBndrL (me_env menv) x1 menv' = menv { me_env = rn_env' } -- Eta expansion the other way -- M ~ (\y.N) iff M y ~ N -match menv subst e1 (Lam x2 e2) - = match menv' subst (App e1 (varToCoreExpr new_x)) e2 +match idu menv subst e1 (Lam x2 e2) + = match idu menv' subst (App e1 (varToCoreExpr new_x)) e2 where (rn_env', new_x) = rnBndrR (me_env menv) x2 menv' = menv { me_env = rn_env' } -match menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) +match idu menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) = do { subst1 <- match_ty menv subst ty1 ty2 - ; subst2 <- match menv subst1 e1 e2 + ; subst2 <- match idu menv subst1 e1 e2 ; let menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 } - ; match_alts menv' subst2 alts1 alts2 -- Alts are both sorted + ; match_alts idu menv' subst2 alts1 alts2 -- Alts are both sorted } -match menv subst (Type ty1) (Type ty2) +match _ menv subst (Type ty1) (Type ty2) = match_ty menv subst ty1 ty2 -match menv subst (Cast e1 co1) (Cast e2 co2) +match idu menv subst (Cast e1 co1) (Cast e2 co2) = do { subst1 <- match_ty menv subst co1 co2 - ; match menv subst1 e1 e2 } + ; match idu menv subst1 e1 e2 } -- Everything else fails -match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ +match _ _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ Nothing ------------------------------------------ -match_var :: MatchEnv +match_var :: IdUnfoldingFun + -> MatchEnv -> SubstEnv -> Var -- Template -> CoreExpr -- Target -> Maybe SubstEnv -match_var menv subst@(tv_subst, id_subst, binds) v1 e2 +match_var idu menv subst@(tv_subst, id_subst, binds) v1 e2 | v1' `elemVarSet` me_tmpls menv = case lookupVarEnv id_subst v1' of Nothing | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2)) @@ -621,7 +628,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' | eqExpr (nukeRnEnvL rn_env) e1' e2 + Just e1' | eqExpr idu (nukeRnEnvL rn_env) e1' e2 -> Just subst | otherwise @@ -642,22 +649,23 @@ match_var menv subst@(tv_subst, id_subst, binds) v1 e2 ------------------------------------------ -match_alts :: MatchEnv - -> SubstEnv - -> [CoreAlt] -- Template - -> [CoreAlt] -- Target - -> Maybe SubstEnv -match_alts _ subst [] [] +match_alts :: IdUnfoldingFun + -> MatchEnv + -> SubstEnv + -> [CoreAlt] -- Template + -> [CoreAlt] -- Target + -> Maybe SubstEnv +match_alts _ _ subst [] [] = return subst -match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) +match_alts idu menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) | c1 == c2 - = do { subst1 <- match menv' subst r1 r2 - ; match_alts menv subst1 alts1 alts2 } + = do { subst1 <- match idu menv' subst r1 r2 + ; match_alts idu menv subst1 alts1 alts2 } where menv' :: MatchEnv menv' = menv { me_env = rnBndrs2 (me_env menv) vs1 vs2 } -match_alts _ _ _ _ +match_alts _ _ _ _ _ = Nothing \end{code} @@ -795,57 +803,55 @@ That is why the 'lookupRnInScope' call in the (Var v2) case of 'match' is so important. \begin{code} -eqExpr :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool +eqExpr :: IdUnfoldingFun -> 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) +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 +eqExpr id_unfolding_fun env (Var v1) e2 | not (locallyBoundL env v1) - , Just e1' <- expandId (lookupRnInScope env v1) - = eqExpr (nukeRnEnvL env) e1' e2 + , Just e1' <- expandUnfolding (id_unfolding_fun (lookupRnInScope env v1)) + = eqExpr id_unfolding_fun (nukeRnEnvL env) e1' e2 -eqExpr env e1 (Var v2) +eqExpr id_unfolding_fun 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 + , Just e2' <- expandUnfolding (id_unfolding_fun (lookupRnInScope env v2)) + = eqExpr id_unfolding_fun (nukeRnEnvR env) e1 e2' + +eqExpr _ _ (Lit lit1) (Lit lit2) = lit1 == lit2 +eqExpr idu env (App f1 a1) (App f2 a2) = eqExpr idu env f1 f2 && eqExpr idu env a1 a2 +eqExpr idu env (Lam v1 e1) (Lam v2 e2) = eqExpr idu (rnBndr2 env v1 v2) e1 e2 +eqExpr idu env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eqExpr idu env e1 e2 +eqExpr idu env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && eqExpr idu env e1 e2 +eqExpr _ env (Type t1) (Type t2) = tcEqTypeX env t1 t2 + +eqExpr idu env (Let (NonRec v1 r1) e1) + (Let (NonRec v2 r2) e2) = eqExpr idu env r1 r2 + && eqExpr idu (rnBndr2 env v1 v2) e1 e2 +eqExpr idu env (Let (Rec ps1) e1) + (Let (Rec ps2) e2) = equalLength ps1 ps2 + && and (zipWith eq_rhs ps1 ps2) + && eqExpr idu 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 idu env' r1 r2 +eqExpr idu env (Case e1 v1 t1 a1) + (Case e2 v2 t2 a2) = eqExpr idu env e1 e2 + && tcEqTypeX env t1 t2 + && equalLength a1 a2 + && and (zipWith eq_alt a1 a2) + where + env' = rnBndr2 env v1 v2 + eq_alt (c1,vs1,r1) (c2,vs2,r2) + = c1==c2 && eqExpr idu (rnBndrs2 env' vs1 vs2) r1 r2 +eqExpr _ _ _ _ = False eq_note :: RnEnv2 -> Note -> Note -> Bool eq_note _ (SCC cc1) (SCC cc2) = cc1 == cc2 @@ -861,12 +867,10 @@ locallyBoundL rn_env v = inRnEnvL rn_env v locallyBoundR rn_env v = inRnEnvR rn_env v -expandId :: Id -> Maybe CoreExpr -expandId id +expandUnfolding :: Unfolding -> Maybe CoreExpr +expandUnfolding unfolding | isExpandableUnfolding unfolding = Just (unfoldingTemplate unfolding) | otherwise = Nothing - where - unfolding = idUnfolding id \end{code} %************************************************************************ @@ -881,12 +885,12 @@ expandId id \begin{code} -- | Report partial matches for rules beginning with the specified -- string for the purposes of error reporting -ruleCheckProgram :: (Activation -> Bool) -- ^ Rule activation test +ruleCheckProgram :: CompilerPhase -- ^ Rule activation test -> String -- ^ Rule pattern -> RuleBase -- ^ Database of rules -> [CoreBind] -- ^ Bindings to check in -> SDoc -- ^ Resulting check message -ruleCheckProgram is_active rule_pat rule_base binds +ruleCheckProgram phase rule_pat rule_base binds | isEmptyBag results = text "Rule check results: no rule application sites" | otherwise @@ -895,11 +899,17 @@ ruleCheckProgram is_active rule_pat rule_base binds vcat [ p $$ line | p <- bagToList results ] ] where - results = unionManyBags (map (ruleCheckBind (RuleCheckEnv is_active rule_pat rule_base)) binds) + env = RuleCheckEnv { rc_is_active = isActive phase + , rc_id_unf = idUnfolding -- Not quite right + -- Should use activeUnfolding + , rc_pattern = rule_pat + , rc_rule_base = rule_base } + results = unionManyBags (map (ruleCheckBind env) binds) line = text (replicate 20 '-') data RuleCheckEnv = RuleCheckEnv { rc_is_active :: Activation -> Bool, + rc_id_unf :: IdUnfoldingFun, rc_pattern :: String, rc_rule_base :: RuleBase } @@ -934,13 +944,13 @@ ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc ruleCheckFun env fn args | null name_match_rules = emptyBag - | otherwise = unitBag (ruleAppCheck_help (rc_is_active env) fn args name_match_rules) + | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) where name_match_rules = filter match (getRules (rc_rule_base env) fn) match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule) -ruleAppCheck_help :: (Activation -> Bool) -> Id -> [CoreExpr] -> [CoreRule] -> SDoc -ruleAppCheck_help is_active fn args rules +ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc +ruleAppCheck_help env fn args rules = -- The rules match the pattern, so we want to print something vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), vcat (map check_rule rules)] @@ -957,14 +967,14 @@ ruleAppCheck_help is_active fn args rules = ptext (sLit "Rule") <+> doubleQuotes (ftext name) rule_info rule - | Just _ <- matchRule noBlackList emptyInScopeSet args rough_args rule + | Just _ <- matchRule noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule = text "matches (which is very peculiar!)" rule_info (BuiltinRule {}) = text "does not match" rule_info (Rule { ru_act = act, ru_bndrs = rule_bndrs, ru_args = rule_args}) - | not (is_active act) = text "active only in later phase" + | not (rc_is_active env act) = text "active only in later phase" | n_args < n_rule_args = text "too few arguments" | n_mismatches == n_rule_args = text "no arguments match" | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not" @@ -976,7 +986,7 @@ ruleAppCheck_help is_active fn args rules not (isJust (match_fn rule_arg arg))] lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars - match_fn rule_arg arg = match menv emptySubstEnv rule_arg arg + match_fn rule_arg arg = match (rc_id_unf env) menv emptySubstEnv rule_arg arg where in_scope = lhs_fvs `unionVarSet` exprFreeVars arg menv = ME { me_env = mkRnEnv2 (mkInScopeSet in_scope) diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 6d071e2..d738565 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -808,7 +808,7 @@ specDefn subst body_uds fn rhs -- Figure out whether the function has an INLINE pragma -- See Note [Inline specialisations] - fn_has_inline_rule :: Maybe InlSatFlag -- Derive sat-flag from existing thing + fn_has_inline_rule :: Maybe Bool -- Derive sat-flag from existing thing fn_has_inline_rule = case isInlineRule_maybe fn_unf of Just (_,sat) -> Just sat Nothing -> Nothing @@ -825,7 +825,8 @@ specDefn subst body_uds fn rhs already_covered :: [CoreExpr] -> Bool already_covered args -- Note [Specialisations already covered] - = isJust (lookupRule (const True) (substInScope subst) + = isJust (lookupRule (const True) realIdUnfolding + (substInScope subst) fn args (idCoreRules fn)) mk_ty_args :: [Maybe Type] -> [CoreExpr] diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs index 125d5de..493015f 100644 --- a/compiler/stranal/WorkWrap.lhs +++ b/compiler/stranal/WorkWrap.lhs @@ -261,7 +261,7 @@ checkSize fn_id rhs thing_inside | otherwise = thing_inside where unfolding = idUnfolding fn_id - inline_rule = mkInlineRule InlUnSat rhs (unfoldingArity unfolding) + inline_rule = mkInlineRule unSaturatedOk rhs (unfoldingArity unfolding) --------------------- splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Activation -> Expr Var diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index 6e7557e..16ac82a 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -789,7 +789,7 @@ vectDataConWorkers orig_tc vect_tc arr_tc raw_worker <- cloneId mkVectOcc orig_worker (exprType body) let vect_worker = raw_worker `setIdUnfolding` - mkInlineRule InlSat body arity + mkInlineRule needSaturated body arity defGlobalVar orig_worker vect_worker return (vect_worker, body) where @@ -830,7 +830,7 @@ buildPADict vect_tc prepr_tc arr_tc repr let body = mkLams (tvs ++ args) expr raw_var <- newExportedVar (method_name name) (exprType body) let var = raw_var - `setIdUnfolding` mkInlineRule InlSat body (length args) + `setIdUnfolding` mkInlineRule needSaturated body (length args) hoistBinding var body return var diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs index 79e0cfb..8dccd61 100644 --- a/compiler/vectorise/VectUtils.hs +++ b/compiler/vectorise/VectUtils.hs @@ -371,7 +371,7 @@ hoistExpr fs expr inl where mk_inline var = case inl of Inline arity -> var `setIdUnfolding` - mkInlineRule InlSat expr arity + mkInlineRule needSaturated expr arity DontInline -> var hoistVExpr :: VExpr -> Inline -> VM VVar diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index 59fded3..cc91e9f 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -106,7 +106,7 @@ vectTopBinder var inline expr return var' where unfolding = case inline of - Inline arity -> mkInlineRule InlSat expr arity + Inline arity -> mkInlineRule needSaturated expr arity DontInline -> noUnfolding vectTopRhs :: Var -> CoreExpr -> VM (Inline, CoreExpr)