1 files changed, 53 insertions, 46 deletions

diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 18b4c9dee3..b950f570b8 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -330,12 +330,14 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
                 (tvs, body) = case collectTyBinders rhs of
                                 (tvs, body) | not_lam body -> (tvs,body)
                                             | otherwise    -> ([], rhs)
-                not_lam (Lam _ _) = False
-                not_lam _         = True
+                not_lam (Lam _ _)  = False
+                not_lam (Tick t e) | not (tickishFloatable t)
+                                   = not_lam e -- eta-reduction could float
+                not_lam _          = True
                         -- Do not do the "abstract tyyvar" thing if there's
                         -- a lambda inside, because it defeats eta-reduction
                         --    f = /\a. \x. g a x
-                        -- should eta-reduce
+                        -- should eta-reduce.
 
 
         ; (body_env, tvs') <- simplBinders rhs_env tvs
@@ -486,6 +488,21 @@ prepareRhs top_lvl env0 _ rhs0
                         -- The definition of is_exp should match that in
                         -- OccurAnal.occAnalApp
 
+    go n_val_args env (Tick t rhs)
+        -- We want to be able to float bindings past this
+        -- tick. Non-scoping ticks don't care.
+        | tickishScoped t == NoScope
+        = do { (is_exp, env', rhs') <- go n_val_args env rhs
+             ; return (is_exp, env', Tick t rhs') }
+        -- On the other hand, for scoping ticks we need to be able to
+        -- copy them on the floats, which in turn is only allowed if
+        -- we can obtain non-counting ticks.
+        | not (tickishCounts t) || tickishCanSplit t
+        = do { (is_exp, env', rhs') <- go n_val_args (zapFloats env) rhs
+             ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)
+                   floats' = seFloats $ env `addFloats` mapFloats env' tickIt
+             ; return (is_exp, env' { seFloats = floats' }, Tick t rhs') }
+
     go _ env other
         = return (False, env, other)
 
@@ -1019,58 +1036,48 @@ simplTick env tickish expr cont
 --  | tickishScoped tickish && not (tickishCounts tickish)
 --  = simplExprF env expr (TickIt tickish cont)
 
-  -- For non-scoped ticks, we push the continuation inside the
-  -- tick.  This has the effect of moving the tick to the outside of a
-  -- case or application context, allowing the normal case and
-  -- application optimisations to fire.
-  | not (tickishScoped tickish)
+  -- For unscoped or soft-scoped ticks, we are allowed to float in new
+  -- cost, so we simply push the continuation inside the tick.  This
+  -- has the effect of moving the tick to the outside of a case or
+  -- application context, allowing the normal case and application
+  -- optimisations to fire.
+  | tickish `tickishScopesLike` SoftScope
   = do { (env', expr') <- simplExprF env expr cont
        ; return (env', mkTick tickish expr')
        }
 
-  -- For breakpoints, we cannot do any floating of bindings around the
-  -- tick, because breakpoints cannot be split into tick/scope pairs.
-  | not (tickishCanSplit tickish)
-  = no_floating_past_tick
-
-  | interesting_cont, Just expr' <- push_tick_inside tickish expr
-    -- see Note [case-of-scc-of-case]
+  -- Push tick inside if the context looks like this will allow us to
+  -- do a case-of-case - see Note [case-of-scc-of-case]
+  | Select {} <- cont, Just expr' <- push_tick_inside
   = simplExprF env expr' cont
 
+  -- We don't want to move the tick, but we might still want to allow
+  -- floats to pass through with appropriate wrapping (or not, see
+  -- wrap_floats below)
+  --- | not (tickishCounts tickish) || tickishCanSplit tickish
+  -- = wrap_floats
+
   | otherwise
-  = no_floating_past_tick -- was: wrap_floats, see below
+  = no_floating_past_tick
 
  where
-  interesting_cont = case cont of
-                        Select {} -> True
-                        _ -> False
-
-  push_tick_inside t expr0
-       = ASSERT(tickishScoped t)
-         case expr0 of
-           Tick t' expr
-              -- scc t (tick t' E)
-              --   Pull the tick to the outside
-              -- This one is important for #5363
-              | not (tickishScoped t')
-                 -> Just (Tick t' (Tick t expr))
-
-              -- scc t (scc t' E)
-              --   Try to push t' into E first, and if that works,
-              --   try to push t in again
-              | Just expr' <- push_tick_inside t' expr
-                 -> push_tick_inside t expr'
-
-              | otherwise -> Nothing
-
-           Case scrut bndr ty alts
-              | not (tickishCanSplit t) -> Nothing
-              | otherwise -> Just (Case (mkTick t scrut) bndr ty alts')
-             where t_scope = mkNoCount t -- drop the tick on the dup'd ones
-                   alts'   = [ (c,bs, mkTick t_scope e) | (c,bs,e) <- alts]
-
-           _other -> Nothing
-    where
+
+  -- Try to push tick inside a case, see Note [case-of-scc-of-case].
+  push_tick_inside =
+    case expr0 of
+      Case scrut bndr ty alts
+             -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts)
+      _other -> Nothing
+   where (ticks, expr0) = stripTicksTop movable (Tick tickish expr)
+         movable t      = not (tickishCounts t) ||
+                          t `tickishScopesLike` NoScope ||
+                          tickishCanSplit t
+         tickScrut e    = foldr mkTick e ticks
+         -- Alternatives get annotated with all ticks that scope in some way,
+         -- but we don't want to count entries.
+         tickAlt (c,bs,e) = (c,bs, foldr mkTick e ts_scope)
+         ts_scope         = map mkNoCount $
+                            filter (not . (`tickishScopesLike` NoScope)) ticks
 
   no_floating_past_tick =
     do { let (inc,outc) = splitCont cont