From 632956d089071969e52de65f27c810dd926e3a79 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones <simonpj@microsoft.com> Date: Tue, 18 Mar 2014 17:10:18 +0000 Subject: [PATCH] Make sure we occurrence-analyse unfoldings (fixes Trac #8892) For DFunUnfoldings we were failing to occurrence-analyse the unfolding, and that meant that a loop breaker wasn't marked as such, which in turn meant it was inlined away when it still had occurrence sites. See Note [Occurrrence analysis of unfoldings] in CoreUnfold. This is a pretty long-standing bug, happily nailed by John Lato. (cherry picked from commit 87bbc69c40d36046492d754c8d7ff02c3be6ce43) --- compiler/coreSyn/CoreUnfold.lhs | 27 +++++++++++- compiler/simplCore/Simplify.lhs | 78 ++++++++++++++++----------------- 2 files changed, 63 insertions(+), 42 deletions(-) diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index a219de8a8cc2..3a2c2376020a 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -98,8 +98,11 @@ mkSimpleUnfolding :: DynFlags -> CoreExpr -> Unfolding mkSimpleUnfolding dflags = mkUnfolding dflags InlineRhs False False mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding -mkDFunUnfolding bndrs con ops - = DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = ops } +mkDFunUnfolding bndrs con ops + = DFunUnfolding { df_bndrs = bndrs + , df_con = con + , df_args = map occurAnalyseExpr ops } + -- See Note [Occurrrence analysis of unfoldings] mkWwInlineRule :: CoreExpr -> Arity -> Unfolding mkWwInlineRule expr arity @@ -143,6 +146,7 @@ mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr -- Occurrence-analyses the expression before capturing it mkCoreUnfolding src top_lvl expr arity guidance = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, + -- See Note [Occurrrence analysis of unfoldings] uf_src = src, uf_arity = arity, uf_is_top = top_lvl, @@ -162,6 +166,7 @@ mkUnfolding dflags src top_lvl is_bottoming expr = NoUnfolding -- See Note [Do not inline top-level bottoming functions] | otherwise = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, + -- See Note [Occurrrence analysis of unfoldings] uf_src = src, uf_arity = arity, uf_is_top = top_lvl, @@ -176,6 +181,24 @@ mkUnfolding dflags src top_lvl is_bottoming expr -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression] \end{code} +Note [Occurrence analysis of unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do occurrence-analysis of unfoldings once and for all, when the +unfolding is built, rather than each time we inline them. + +But given this decision it's vital that we do +*always* do it. Consider this unfolding + \x -> letrec { f = ...g...; g* = f } in body +where g* is (for some strange reason) the loop breaker. If we don't +occ-anal it when reading it in, we won't mark g as a loop breaker, and +we may inline g entirely in body, dropping its binding, and leaving +the occurrence in f out of scope. This happened in Trac #8892, where +the unfolding in question was a DFun unfolding. + +But more generally, the simplifier is designed on the +basis that it is looking at occurrence-analysed expressions, so better +ensure that they acutally are. + Note [Calculate unfolding guidance on the non-occ-anal'd expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Notice that we give the non-occur-analysed expression to diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 3873ed3c822b..765dc45f148a 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -730,53 +730,51 @@ simplUnfolding :: SimplEnv-> TopLevelFlag -> OutExpr -> Unfolding -> SimplM Unfolding -- Note [Setting the new unfolding] -simplUnfolding env _ _ _ df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) - = do { (env', bndrs') <- simplBinders env bndrs - ; args' <- mapM (simplExpr env') args - ; return (df { df_bndrs = bndrs', df_args = args' }) } - -simplUnfolding env top_lvl id _ - (CoreUnfolding { uf_tmpl = expr, uf_arity = arity - , uf_src = src, uf_guidance = guide }) - | isStableSource src - = do { expr' <- simplExpr rule_env expr - ; let is_top_lvl = isTopLevel top_lvl - ; case guide of - UnfWhen sat_ok _ -- Happens for INLINE things - -> let guide' = UnfWhen sat_ok (inlineBoringOk expr') - -- Refresh the boring-ok flag, in case expr' - -- has got small. This happens, notably in the inlinings - -- for dfuns for single-method classes; see - -- Note [Single-method classes] in TcInstDcls. - -- A test case is Trac #4138 - in return (mkCoreUnfolding src is_top_lvl expr' arity guide') - -- See Note [Top-level flag on inline rules] in CoreUnfold - - _other -- Happens for INLINABLE things - -> let bottoming = isBottomingId id - in bottoming `seq` -- See Note [Force bottoming field] - do dflags <- getDynFlags - return (mkUnfolding dflags src is_top_lvl bottoming expr') +simplUnfolding env top_lvl id new_rhs unf + = case unf of + DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args } + -> do { (env', bndrs') <- simplBinders rule_env bndrs + ; args' <- mapM (simplExpr env') args + ; return (mkDFunUnfolding bndrs' con args') } + + CoreUnfolding { uf_tmpl = expr, uf_arity = arity + , uf_src = src, uf_guidance = guide } + | isStableSource src + -> do { expr' <- simplExpr rule_env expr + ; case guide of + UnfWhen sat_ok _ -- Happens for INLINE things + -> let guide' = UnfWhen sat_ok (inlineBoringOk expr') + -- Refresh the boring-ok flag, in case expr' + -- has got small. This happens, notably in the inlinings + -- for dfuns for single-method classes; see + -- Note [Single-method classes] in TcInstDcls. + -- A test case is Trac #4138 + in return (mkCoreUnfolding src is_top_lvl expr' arity guide') + -- See Note [Top-level flag on inline rules] in CoreUnfold + + _other -- Happens for INLINABLE things + -> bottoming `seq` -- See Note [Force bottoming field] + do { dflags <- getDynFlags + ; return (mkUnfolding dflags src is_top_lvl bottoming 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 -> bottoming `seq` -- See Note [Force bottoming field] + do { dflags <- getDynFlags + ; return (mkUnfolding dflags InlineRhs is_top_lvl bottoming new_rhs) } + -- We make an unfolding *even for loop-breakers*. + -- Reason: (a) It might be useful to know that they are WHNF + -- (b) In TidyPgm we currently assume that, if we want to + -- expose the unfolding then indeed we *have* an unfolding + -- to expose. (We could instead use the RHS, but currently + -- we don't.) The simple thing is always to have one. where + bottoming = isBottomingId id + is_top_lvl = isTopLevel top_lvl act = idInlineActivation id rule_env = updMode (updModeForInlineRules act) env -- See Note [Simplifying inside InlineRules] in SimplUtils - -simplUnfolding _ top_lvl id new_rhs _ - = let bottoming = isBottomingId id - in bottoming `seq` -- See Note [Force bottoming field] - do dflags <- getDynFlags - return (mkUnfolding dflags InlineRhs (isTopLevel top_lvl) bottoming new_rhs) - -- We make an unfolding *even for loop-breakers*. - -- Reason: (a) It might be useful to know that they are WHNF - -- (b) In TidyPgm we currently assume that, if we want to - -- expose the unfolding then indeed we *have* an unfolding - -- to expose. (We could instead use the RHS, but currently - -- we don't.) The simple thing is always to have one. \end{code} Note [Force bottoming field] -- GitLab