diff options
25 files changed, 596 insertions, 460 deletions
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 1eacea9938..aaeb3bc578 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 3ff583ee20..1e8c9e7b0b 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 b02bc80578..b5d7fde99d 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 072463081b..5c7cef9ac9 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 fd76f235bd..0510e90d6d 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 9761db150a..1590978d33 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 950e37bc84..4d828b65b0 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 "<vanilla>") 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 "<rhs>")) + 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 0bb7045ec5..4a11ea2ed9 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 = <f-rhs> 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 53400393f5..fa57d41e45 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 be68afe77f..9485dc9453 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 cad384cb82..9282920bee 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 cecfc0b742..2ec9de97a0 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 ab09f62537..8e173284ba 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 8f3a52086d..6a9f0ddfce 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 1515fb9827..bc8c9b81bc 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 5824874b58..2199ab1b66 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 beb1ed0e7c..5dfd40b144 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 87db9a8009..7a5b96b352 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 875061d045..37fa798965 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 cc5054a10c..90485d0487 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 6d071e22b6..d738565856 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 125d5de5b2..493015fb28 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 6e7557e9e2..16ac82adca 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 79e0cfb842..8dccd61c24 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 59fded3c4f..cc91e9fc9c 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) |