simplTick: push type-applications and casts inside ticks.

1 files changed, 15 insertions, 5 deletions

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index d4108d20fd..853815c2ce 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1038,19 +1038,21 @@ simplTick env tickish expr cont
   --
 
   -- For breakpoints, we cannot do any floating of bindings around the
-  -- tick.  So
+  -- tick, because breakpoints cannot be split into tick/scope pairs.
   | Breakpoint{} <- tickish
-  = do { (env', expr') <- simplExprF (zapFloats env) expr mkBoringStop
+  = do { let (inc,outc) = splitCont cont
+       ; (env', expr') <- simplExprF (zapFloats env) expr inc
        ; let tickish' = simplTickish env tickish
-       ; (env'', expr'') <- rebuild (zapFloats env') (wrapFloats env' expr') (TickIt tickish' cont)
+       ; (env'', expr'') <- rebuild (zapFloats env') (wrapFloats env' expr') (TickIt tickish' outc)
        ; return (env'', wrapFloats env expr'')
        }
 
   | otherwise
-  = do { (env', expr') <- simplExprF (zapFloats env) expr mkBoringStop
+  = do { let (inc,outc) = splitCont cont
+       ; (env', expr') <- simplExprF (zapFloats env) expr inc
        ; let tickish' = simplTickish env tickish
        ; let env'' = addFloats env (mapFloatRhss env' (mkTick (mkNoTick tickish')))
-       ; rebuild env'' expr' (TickIt tickish' cont)
+       ; rebuild env'' expr' (TickIt tickish' outc)
        }
  where
   simplTickish env tickish
@@ -1058,6 +1060,14 @@ simplTick env tickish expr cont
           = Breakpoint n (map (getDoneId . substId env) ids)
     | otherwise = tickish
 
+  -- push type application and coercion inside a tick
+  splitCont :: SimplCont -> (SimplCont, SimplCont)
+  splitCont (ApplyTo f (Type t) env c) = (ApplyTo f (Type t) env inc, outc)
+    where (inc,outc) = splitCont c
+  splitCont (CoerceIt co c) = (CoerceIt co inc, outc)
+    where (inc,outc) = splitCont c
+  splitCont other = (mkBoringStop, other)
+
   getDoneId (DoneId id) = id
   getDoneId (DoneEx e)  = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst
   getDoneId other = pprPanic "getDoneId" (ppr other)