diff options
author | Peter Wortmann <scpmw@leeds.ac.uk> | 2015-01-19 07:57:19 -0600 |
---|---|---|
committer | Austin Seipp <austin@well-typed.com> | 2015-01-19 07:57:35 -0600 |
commit | 55199a97c020761ff4bfdc06da0042e43bede697 (patch) | |
tree | 8636cf3aa8051cbdb8da44125dec2ccbe08b9e01 | |
parent | d839493991e508160d416311ba47b7a7e2d62aae (diff) | |
download | haskell-55199a97c020761ff4bfdc06da0042e43bede697.tar.gz |
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: Austin Seipp <austin@well-typed.com>
-rw-r--r-- | compiler/coreSyn/CoreLint.hs | 2 | ||||
-rw-r--r-- | compiler/coreSyn/CoreUtils.hs | 55 | ||||
-rw-r--r-- | compiler/simplCore/CSE.hs | 10 | ||||
-rw-r--r-- | compiler/simplCore/SimplUtils.hs | 4 | ||||
-rw-r--r-- | testsuite/tests/perf/compiler/all.T | 10 |
5 files changed, 51 insertions, 30 deletions
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 3dca78e2d6..5ae7a59459 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 135f81a4a1..28981a3fe8 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 a30c695181..c43cbb778e 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 ccc8a56cc0..6bb290e6fb 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 62fe32a4a9..ece12432fc 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -617,3 +617,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']) |