diff options
Diffstat (limited to 'compiler/GHC/Core')
| -rw-r--r-- | compiler/GHC/Core/Opt/FloatOut.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 11 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify/Env.hs | 5 |
3 files changed, 15 insertions, 5 deletions
diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs index fbed53fbf3..524c4a5cd0 100644 --- a/compiler/GHC/Core/Opt/FloatOut.hs +++ b/compiler/GHC/Core/Opt/FloatOut.hs @@ -8,7 +8,7 @@ -module GHC.Core.Opt.FloatOut ( floatOutwards ) where +module GHC.Core.Opt.FloatOut ( floatOutwards, wrapTick ) where import GHC.Prelude @@ -418,7 +418,7 @@ floatExpr lam@(Lam (TB _ lam_spec) _) floatExpr (Tick tickish expr) | tickish `tickishScopesLike` SoftScope -- not scoped, can just float = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') -> - (fs, floating_defns, Tick tickish expr') } + (fs, wrapTick tickish floating_defns, Tick tickish expr') } | not (tickishCounts tickish) || tickishCanSplit tickish = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') -> diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 1398bfd6e7..4558686eb1 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -1312,8 +1312,15 @@ simplTick env tickish expr cont -- application context, allowing the normal case and application -- optimisations to fire. | tickish `tickishScopesLike` SoftScope - = do { (floats, expr') <- simplExprF env expr cont - ; return (floats, mkTick tickish expr') + = do { -- pprTraceM "simpl_tick1" (ppr tickish) + ; (floats, expr') <- simplExprF env expr cont + --; pprTraceM "simpl_tick" (ppr floats $$ ppr tickish $$ ppr floats $$ ppr expr $$ ppr cont $$ ppr expr') + ; let wrap_float (b,rhs) = (zapIdDmdSig (setIdArity b 0), + mkTick (mkNoCount tickish) rhs) + -- when wrapping a float with mkTick, we better zap the Id's + -- strictness info and arity, because it might be wrong now. + ; let floats' = mapFloats wrap_float floats + ; return (floats', mkTick tickish expr') } -- Push tick inside if the context looks like this will allow us to diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs index 54a5f171ec..8be549602b 100644 --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -32,7 +32,7 @@ module GHC.Core.Opt.Simplify.Env ( SimplFloats(..), emptyFloats, mkRecFloats, mkFloatBind, addLetFloats, addJoinFloats, addFloats, extendFloats, wrapFloats, - doFloatFromRhs, getTopFloatBinds, + doFloatFromRhs, getTopFloatBinds, mapFloats, -- * LetFloats LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat, @@ -126,6 +126,9 @@ data SimplFloats , sfInScope :: InScopeSet -- All OutVars } +mapFloats :: ((Id, CoreExpr) -> (Id, CoreExpr)) -> SimplFloats -> SimplFloats +mapFloats f sf = sf { sfLetFloats = mapLetFloats (sfLetFloats sf) f } + instance Outputable SimplFloats where ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is }) = text "SimplFloats" |