Commit 174082ff authored by Peter Wortmann's avatar Peter Wortmann Committed by thoughtpolice

Split stripTicks into expression editing and tick collection

As with stripTicksTop, this is because we often need the stripped
expression but not the ticks (at least not right away). This makes a big
difference for CSE, see #9961.
Signed-off-by: default avatarAustin Seipp <austin@well-typed.com>
(cherry picked from commit 55199a97)
parent 5eae13b9
...@@ -1759,7 +1759,7 @@ withoutAnnots pass guts = do ...@@ -1759,7 +1759,7 @@ withoutAnnots pass guts = do
-- Nuke existing ticks in module. -- Nuke existing ticks in module.
-- TODO: Ticks in unfoldings. Maybe change unfolding so it removes -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes
-- them in absence of @Opt_Debug@? -- them in absence of @Opt_Debug@?
let nukeTicks = snd . stripTicks (not . tickishIsCode) let nukeTicks = stripTicksE (not . tickishIsCode)
nukeAnnotsBind :: CoreBind -> CoreBind nukeAnnotsBind :: CoreBind -> CoreBind
nukeAnnotsBind bind = case bind of nukeAnnotsBind bind = case bind of
Rec bs -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs Rec bs -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs
......
...@@ -44,7 +44,8 @@ module CoreUtils ( ...@@ -44,7 +44,8 @@ module CoreUtils (
dataConRepInstPat, dataConRepFSInstPat, dataConRepInstPat, dataConRepFSInstPat,
-- * Working with ticks -- * Working with ticks
stripTicksTop, stripTicksTopE, stripTicksTopT, stripTicks, stripTicksTop, stripTicksTopE, stripTicksTopT,
stripTicksE, stripTicksT
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -77,10 +78,6 @@ import Pair ...@@ -77,10 +78,6 @@ import Pair
import Data.Function ( on ) import Data.Function ( on )
import Data.List import Data.List
import Data.Ord ( comparing ) import Data.Ord ( comparing )
import Control.Applicative
#if __GLASGOW_HASKELL__ < 709
import Data.Traversable ( traverse )
#endif
import OrdList import OrdList
{- {-
...@@ -358,25 +355,37 @@ stripTicksTopT p = go [] ...@@ -358,25 +355,37 @@ stripTicksTopT p = go []
-- | Completely strip ticks satisfying a predicate from an -- | Completely strip ticks satisfying a predicate from an
-- expression. Note this is O(n) in the size of the expression! -- expression. Note this is O(n) in the size of the expression!
stripTicks :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b) stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b
stripTicks p expr = (fromOL ticks, expr') stripTicksE p expr = go expr
where (ticks, expr') = go expr where go (App e a) = App (go e) (go a)
-- Note that OrdList (Tickish Id) is a Monoid, which makes go (Lam b e) = Lam b (go e)
-- ((,) (OrdList (Tickish Id))) an Applicative. go (Let b e) = Let (go_bs b) (go e)
go (App e a) = App <$> go e <*> go a go (Case e b t as) = Case (go e) b t (map go_a as)
go (Lam b e) = Lam b <$> go e go (Cast e c) = Cast (go e) c
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
go (Tick t e) go (Tick t e)
| p t = let (ts, e') = go e in (t `consOL` ts, e') | p t = go e
| otherwise = Tick t <$> go e | otherwise = Tick t (go e)
go other = pure other go other = other
go_bs (NonRec b e) = NonRec b <$> go e go_bs (NonRec b e) = NonRec b (go e)
go_bs (Rec bs) = Rec <$> traverse go_b bs go_bs (Rec bs) = Rec (map go_b bs)
go_b (b, e) = (,) <$> pure b <*> go e go_b (b, e) = (b, go e)
go_a (c,bs,e) = (,,) <$> pure c <*> pure bs <*> 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
{- {-
************************************************************************ ************************************************************************
......
...@@ -15,7 +15,7 @@ import Var ( Var ) ...@@ -15,7 +15,7 @@ import Var ( Var )
import Id ( Id, idType, idInlineActivation, zapIdOccInfo ) import Id ( Id, idType, idInlineActivation, zapIdOccInfo )
import CoreUtils ( mkAltExpr import CoreUtils ( mkAltExpr
, exprIsTrivial , exprIsTrivial
, stripTicks, stripTicksTopE, mkTick, mkTicks ) , stripTicksE, stripTicksT, stripTicksTopE, mkTick, mkTicks )
import Type ( tyConAppArgs ) import Type ( tyConAppArgs )
import CoreSyn import CoreSyn
import Outputable import Outputable
...@@ -190,7 +190,8 @@ cseRhs env (id',rhs) ...@@ -190,7 +190,8 @@ cseRhs env (id',rhs)
where where
rhs' = cseExpr env rhs 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 -- We don't want to lose the source notes when a common sub
-- expression gets eliminated. Hence we push all (!) of them on -- expression gets eliminated. Hence we push all (!) of them on
-- top of the replaced sub-expression. This is probably not too -- top of the replaced sub-expression. This is probably not too
...@@ -206,7 +207,8 @@ tryForCSE env expr ...@@ -206,7 +207,8 @@ tryForCSE env expr
| otherwise = expr' | otherwise = expr'
where where
expr' = cseExpr env expr expr' = cseExpr env expr
(ticks, expr'') = stripTicks tickishFloatable expr' expr'' = stripTicksE tickishFloatable expr'
ticks = stripTicksT tickishFloatable expr'
cseExpr :: CSEnv -> InExpr -> OutExpr cseExpr :: CSEnv -> InExpr -> OutExpr
cseExpr env (Type t) = Type (substTy (csEnvSubst env) t) cseExpr env (Type t) = Type (substTy (csEnvSubst env) t)
...@@ -296,7 +298,7 @@ lookupCSEnv (CS { cs_map = csmap }) expr ...@@ -296,7 +298,7 @@ lookupCSEnv (CS { cs_map = csmap }) expr
extendCSEnv :: CSEnv -> OutExpr -> Id -> CSEnv extendCSEnv :: CSEnv -> OutExpr -> Id -> CSEnv
extendCSEnv cse expr id extendCSEnv cse expr id
= cse { cs_map = extendCoreMap (cs_map cse) sexpr (sexpr,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 :: CSEnv -> Subst
csEnvSubst = cs_subst csEnvSubst = cs_subst
......
...@@ -1658,7 +1658,7 @@ combineIdenticalAlts case_bndr ((_con1,bndrs1,rhs1) : con_alts) ...@@ -1658,7 +1658,7 @@ combineIdenticalAlts case_bndr ((_con1,bndrs1,rhs1) : con_alts)
cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2 cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2
identical_to_alt1 (_con,bndrs,rhs) identical_to_alt1 (_con,bndrs,rhs)
= all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1 = 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 combineIdenticalAlts _ alts = return alts
...@@ -1755,7 +1755,7 @@ mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _) -- Identity case ...@@ -1755,7 +1755,7 @@ mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _) -- Identity case
= do { tick (CaseIdentity case_bndr) = do { tick (CaseIdentity case_bndr)
; return (mkTicks ticks $ re_cast scrut rhs1) } ; return (mkTicks ticks $ re_cast scrut rhs1) }
where 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 identity_alt (con, args, rhs) = check_eq rhs con args
check_eq (Cast rhs co) con args check_eq (Cast rhs co) con args
......
...@@ -601,3 +601,13 @@ test('T9872d', ...@@ -601,3 +601,13 @@ test('T9872d',
], ],
compile, compile,
['']) [''])
test('T9961',
[ only_ways(['normal']),
compiler_stats_num_field('bytes allocated',
[(wordsize(64), 772510192, 5)
# 2015-01-12 807117816 Initally created
]),
],
compile,
['-O'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment