summaryrefslogtreecommitdiff
path: root/compiler/simplCore/Simplify.lhs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/simplCore/Simplify.lhs')
-rw-r--r--compiler/simplCore/Simplify.lhs35
1 files changed, 25 insertions, 10 deletions
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index a8f7761e61..2d84249e97 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1031,7 +1031,7 @@ simplTick env tickish expr cont
| not (tickishCanSplit tickish)
= no_floating_past_tick
- | Just expr' <- want_to_push_tick_inside
+ | interesting_cont, Just expr' <- push_tick_inside tickish expr
-- see Note [case-of-scc-of-case]
= simplExprF env expr' cont
@@ -1039,20 +1039,35 @@ simplTick env tickish expr cont
= no_floating_past_tick -- was: wrap_floats, see below
where
- want_to_push_tick_inside
- | not interesting_cont = Nothing
- | not (tickishCanSplit tickish) = Nothing
+ interesting_cont = case cont of
+ Select _ _ _ _ _ -> True
+ _ -> False
+
+ push_tick_inside t expr0
+ | not (tickishCanSplit t) = Nothing
| otherwise
- = case expr of
+ = 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
- -> Just (Case (mkTick tickish scrut) bndr ty alts')
- where t_scope = mkNoTick tickish -- drop the tick on the dup'd ones
+ -> Just (Case (mkTick t scrut) bndr ty alts')
+ where t_scope = mkNoTick t -- drop the tick on the dup'd ones
alts' = [ (c,bs, mkTick t_scope e) | (c,bs,e) <- alts]
_other -> Nothing
where
- interesting_cont = case cont of
- Select _ _ _ _ _ -> True
- _ -> False
no_floating_past_tick =
do { let (inc,outc) = splitCont cont