Source note changeswip/source-notes-change

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"