diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 3dca78e2d667ab7d482175e062baba450a604ab1..5ae7a594593c93c1c728efaaf77157e6e2029a70 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -1759,7 +1759,7 @@ withoutAnnots pass guts = do
-- Nuke existing ticks in module.
-- TODO: Ticks in unfoldings. Maybe change unfolding so it removes
-- them in absence of @Opt_Debug@?
- let nukeTicks = snd . stripTicks (not . tickishIsCode)
+ let nukeTicks = stripTicksE (not . tickishIsCode)
nukeAnnotsBind :: CoreBind -> CoreBind
nukeAnnotsBind bind = case bind of
Rec bs -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs
diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index 913dda3ad569f8b477a3c11b7622d700d7edc9c2..7030e39e1ebb2a42c71747f07cb97d3f681627dc 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -44,7 +44,8 @@ module CoreUtils (
dataConRepInstPat, dataConRepFSInstPat,
-- * Working with ticks
- stripTicksTop, stripTicksTopE, stripTicksTopT, stripTicks,
+ stripTicksTop, stripTicksTopE, stripTicksTopT,
+ stripTicksE, stripTicksT
) where
#include "HsVersions.h"
@@ -77,10 +78,6 @@ import Pair
import Data.Function ( on )
import Data.List
import Data.Ord ( comparing )
-import Control.Applicative
-#if __GLASGOW_HASKELL__ < 709
-import Data.Traversable ( traverse )
-#endif
import OrdList
{-
@@ -358,25 +355,37 @@ stripTicksTopT p = go []
-- | Completely strip ticks satisfying a predicate from an
-- expression. Note this is O(n) in the size of the expression!
-stripTicks :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)
-stripTicks p expr = (fromOL ticks, expr')
- where (ticks, expr') = go expr
- -- Note that OrdList (Tickish Id) is a Monoid, which makes
- -- ((,) (OrdList (Tickish Id))) an Applicative.
- go (App e a) = App <$> go e <*> go a
- go (Lam b e) = Lam b <$> go e
- go (Let b e) = Let <$> go_bs b <*> go e
- go (Case e b t as) = Case <$> go e <*> pure b <*> pure t
- <*> traverse go_a as
- go (Cast e c) = Cast <$> go e <*> pure c
+stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b
+stripTicksE p expr = go expr
+ where go (App e a) = App (go e) (go a)
+ go (Lam b e) = Lam b (go e)
+ go (Let b e) = Let (go_bs b) (go e)
+ go (Case e b t as) = Case (go e) b t (map go_a as)
+ go (Cast e c) = Cast (go e) c
go (Tick t e)
- | p t = let (ts, e') = go e in (t `consOL` ts, e')
- | otherwise = Tick t <$> go e
- go other = pure other
- go_bs (NonRec b e) = NonRec b <$> go e
- go_bs (Rec bs) = Rec <$> traverse go_b bs
- go_b (b, e) = (,) <$> pure b <*> go e
- go_a (c,bs,e) = (,,) <$> pure c <*> pure bs <*> go e
+ | p t = go e
+ | otherwise = Tick t (go e)
+ go other = other
+ go_bs (NonRec b e) = NonRec b (go e)
+ go_bs (Rec bs) = Rec (map go_b bs)
+ go_b (b, e) = (b, go e)
+ go_a (c,bs,e) = (c,bs, go e)
+
+stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]
+stripTicksT p expr = fromOL $ go expr
+ where go (App e a) = go e `appOL` go a
+ go (Lam _ e) = go e
+ go (Let b e) = go_bs b `appOL` go e
+ go (Case e _ _ as) = go e `appOL` concatOL (map go_a as)
+ go (Cast e _) = go e
+ go (Tick t e)
+ | p t = t `consOL` go e
+ | otherwise = go e
+ go _ = nilOL
+ go_bs (NonRec _ e) = go e
+ go_bs (Rec bs) = concatOL (map go_b bs)
+ go_b (_, e) = go e
+ go_a (_, _, e) = go e
{-
************************************************************************
diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs
index a30c695181dd65a850ad9eda820ce09aa87d9434..c43cbb778e95c642709317a62517cdc0e12e5dcb 100644
--- a/compiler/simplCore/CSE.hs
+++ b/compiler/simplCore/CSE.hs
@@ -15,7 +15,7 @@ import Var ( Var )
import Id ( Id, idType, idInlineActivation, zapIdOccInfo )
import CoreUtils ( mkAltExpr
, exprIsTrivial
- , stripTicks, stripTicksTopE, mkTick, mkTicks )
+ , stripTicksE, stripTicksT, stripTicksTopE, mkTick, mkTicks )
import Type ( tyConAppArgs )
import CoreSyn
import Outputable
@@ -190,7 +190,8 @@ cseRhs env (id',rhs)
where
rhs' = cseExpr env rhs
- (ticks, rhs'') = stripTicks tickishFloatable rhs'
+ ticks = stripTicksT tickishFloatable rhs'
+ rhs'' = stripTicksE tickishFloatable rhs'
-- We don't want to lose the source notes when a common sub
-- expression gets eliminated. Hence we push all (!) of them on
-- top of the replaced sub-expression. This is probably not too
@@ -206,7 +207,8 @@ tryForCSE env expr
| otherwise = expr'
where
expr' = cseExpr env expr
- (ticks, expr'') = stripTicks tickishFloatable expr'
+ expr'' = stripTicksE tickishFloatable expr'
+ ticks = stripTicksT tickishFloatable expr'
cseExpr :: CSEnv -> InExpr -> OutExpr
cseExpr env (Type t) = Type (substTy (csEnvSubst env) t)
@@ -296,7 +298,7 @@ lookupCSEnv (CS { cs_map = csmap }) expr
extendCSEnv :: CSEnv -> OutExpr -> Id -> CSEnv
extendCSEnv cse expr id
= cse { cs_map = extendCoreMap (cs_map cse) sexpr (sexpr,id) }
- where (_, sexpr) = stripTicks tickishFloatable expr
+ where sexpr = stripTicksE tickishFloatable expr
csEnvSubst :: CSEnv -> Subst
csEnvSubst = cs_subst
diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs
index ccc8a56cc04400c278b950d15ab7c2bb6e48680f..6bb290e6fb658447a1299c5580199b39434da283 100644
--- a/compiler/simplCore/SimplUtils.hs
+++ b/compiler/simplCore/SimplUtils.hs
@@ -1658,7 +1658,7 @@ combineIdenticalAlts case_bndr ((_con1,bndrs1,rhs1) : con_alts)
cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2
identical_to_alt1 (_con,bndrs,rhs)
= all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1
- tickss = map (fst . stripTicks tickishFloatable . thirdOf3) eliminated_alts
+ tickss = map (stripTicksT tickishFloatable . thirdOf3) eliminated_alts
combineIdenticalAlts _ alts = return alts
@@ -1755,7 +1755,7 @@ mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _) -- Identity case
= do { tick (CaseIdentity case_bndr)
; return (mkTicks ticks $ re_cast scrut rhs1) }
where
- ticks = concatMap (fst . stripTicks tickishFloatable . thirdOf3) (tail alts)
+ ticks = concatMap (stripTicksT tickishFloatable . thirdOf3) (tail alts)
identity_alt (con, args, rhs) = check_eq rhs con args
check_eq (Cast rhs co) con args
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index ce48c117a0590be9530370626d445b1cdf405c84..31b0a5ad638950e1e52a4a90b06bfd9a7982c3a6 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -601,3 +601,13 @@ test('T9872d',
],
compile,
[''])
+
+test('T9961',
+ [ only_ways(['normal']),
+ compiler_stats_num_field('bytes allocated',
+ [(wordsize(64), 772510192, 5)
+ # 2015-01-12 807117816 Initally created
+ ]),
+ ],
+ compile,
+ ['-O'])