Split stripTicks into expression editing and tick collection
authorPeter Wortmann <scpmw@leeds.ac.uk>
Mon, 19 Jan 2015 13:57:19 +0000 (07:57 -0600)
committerAustin Seipp <austin@well-typed.com>
Mon, 19 Jan 2015 13:57:35 +0000 (07:57 -0600)
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>
compiler/coreSyn/CoreLint.hs
compiler/coreSyn/CoreUtils.hs
compiler/simplCore/CSE.hs
compiler/simplCore/SimplUtils.hs
testsuite/tests/perf/compiler/all.T

index 3dca78e..5ae7a59 100644 (file)
@@ -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
index 135f81a..28981a3 100644 (file)
@@ -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
 
 {-
 ************************************************************************
index a30c695..c43cbb7 100644 (file)
@@ -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
index ccc8a56..6bb290e 100644 (file)
@@ -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
index 62fe32a..ece1243 100644 (file)
@@ -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'])