From 4c9154facefe185dcbb99e2bb1cfe118f02f8bd3 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Fri, 15 Oct 2010 09:48:36 +0000 Subject: [PATCH] Fix #4346 (INLINABLE pragma not behaving consistently) Debugged thanks to lots of help from Simon PJ: we weren't updating the UnfoldingGuidance when the unfolding changed. Also, a bit of refactoring and additinoal comments. --- compiler/coreSyn/CoreSyn.lhs | 15 ++++++++++++++- compiler/coreSyn/CoreUnfold.lhs | 19 ++++++++++--------- compiler/iface/IfaceSyn.lhs | 4 +++- compiler/iface/TcIface.lhs | 2 +- compiler/simplCore/Simplify.lhs | 11 ++++++++++- 5 files changed, 38 insertions(+), 13 deletions(-) diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 5e03e4d..1181931 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -483,7 +483,20 @@ data UnfoldingSource -- Replace uf_tmpl each time around | InlineStable -- From an INLINE or INLINABLE pragma - -- Do not replace uf_tmpl; instead, keep it unchanged + -- INLINE if guidance is UnfWhen + -- INLINABLE if guidance is UnfIfGoodArgs + -- (well, technically an INLINABLE might be made + -- UnfWhen if it was small enough, and then + -- it will behave like INLINE outside the current + -- module, but that is the way automatic unfoldings + -- work so it is consistent with the intended + -- meaning of INLINABLE). + -- + -- uf_tmpl may change, but only as a result of + -- gentle simplification, it doesn't get updated + -- to the current RHS during compilation as with + -- InlineRhs. + -- -- See Note [InlineRules] | InlineCompulsory -- Something that *has* no binding, so you *must* inline it diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 18a0445..7ab0e23 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -104,20 +104,20 @@ mkDFunUnfolding dfun_ty ops mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding mkWwInlineRule id expr arity - = mkCoreUnfolding True (InlineWrapper id) + = mkCoreUnfolding (InlineWrapper id) True (simpleOptExpr expr) arity (UnfWhen unSaturatedOk boringCxtNotOk) mkCompulsoryUnfolding :: CoreExpr -> Unfolding mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded - = mkCoreUnfolding True InlineCompulsory + = mkCoreUnfolding InlineCompulsory True expr 0 -- Arity of unfolding doesn't matter (UnfWhen unSaturatedOk boringCxtOk) mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding mkInlineUnfolding mb_arity expr - = mkCoreUnfolding True -- Note [Top-level flag on inline rules] - InlineStable + = mkCoreUnfolding InlineStable + True -- Note [Top-level flag on inline rules] expr' arity (UnfWhen unsat_ok boring_ok) where @@ -135,18 +135,19 @@ mkInlineUnfolding mb_arity expr mkInlinableUnfolding :: CoreExpr -> Unfolding mkInlinableUnfolding expr - = mkUnfolding InlineStable True is_bot expr + = mkUnfolding InlineStable True is_bot expr' where - is_bot = isJust (exprBotStrictness_maybe expr) + expr' = simpleOptExpr expr + is_bot = isJust (exprBotStrictness_maybe expr') \end{code} Internal functions \begin{code} -mkCoreUnfolding :: Bool -> UnfoldingSource -> CoreExpr +mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr -> Arity -> UnfoldingGuidance -> Unfolding -- Occurrence-analyses the expression before capturing it -mkCoreUnfolding top_lvl src expr arity guidance +mkCoreUnfolding src top_lvl expr arity guidance = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, uf_src = src, uf_arity = arity, @@ -1307,4 +1308,4 @@ Note [DFun arity check] ~~~~~~~~~~~~~~~~~~~~~~~ Here we check that the total number of supplied arguments (inclding type args) matches what the dfun is expecting. This may be *less* -than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn \ No newline at end of file +than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index c753375..3d40b38 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -212,10 +212,12 @@ data IfaceInfoItem data IfaceUnfolding = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding + -- Possibly could eliminate the Bool here, the information + -- is also in the InlinePragma. | IfCompulsory IfaceExpr -- Only used for default methods, in fact - | IfInlineRule Arity + | IfInlineRule Arity -- INLINE pragmas Bool -- OK to inline even if *un*-saturated Bool -- OK to inline even if context is boring IfaceExpr diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index cbb74be..ba1da60 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -1034,7 +1034,7 @@ tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr) = do { mb_expr <- tcPragExpr name if_expr ; return (case mb_expr of Nothing -> NoUnfolding - Just expr -> mkCoreUnfolding True InlineStable expr arity + Just expr -> mkCoreUnfolding InlineStable True expr arity (UnfWhen unsat_ok boring_ok)) } diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 9e73359..2e1110f 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -718,8 +718,17 @@ simplUnfolding env top_lvl id _ _ | isStableSource src = do { expr' <- simplExpr rule_env expr ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src - ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) } + is_top_lvl = isTopLevel top_lvl + ; case guide of + UnfIfGoodArgs{} -> + return (mkUnfolding src' is_top_lvl (isBottomingId id) expr') + -- If the guidance is UnfIfGoodArgs, this is an INLINABLE + -- unfolding, and we need to make sure the guidance is kept up + -- to date with respect to any changes in the unfolding. + _other -> + return (mkCoreUnfolding src' is_top_lvl expr' arity guide) -- See Note [Top-level flag on inline rules] in CoreUnfold + } where act = idInlineActivation id rule_env = updMode (updModeForInlineRules act) env -- 1.7.10.4