[commit: ghc] ghc-7.10: Split stripTicks into expression editing and tick collection (174082f)

git at git.haskell.org git at git.haskell.org
Fri Jan 23 18:04:07 UTC 2015


Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-7.10
Link       : http://ghc.haskell.org/trac/ghc/changeset/174082ffeb69b2f9df19e7af7b63a331dd074145/ghc

>---------------------------------------------------------------

commit 174082ffeb69b2f9df19e7af7b63a331dd074145
Author: Peter Wortmann <scpmw at leeds.ac.uk>
Date:   Mon Jan 19 07:57:19 2015 -0600

    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 at well-typed.com>
    (cherry picked from commit 55199a97c020761ff4bfdc06da0042e43bede697)


>---------------------------------------------------------------

174082ffeb69b2f9df19e7af7b63a331dd074145
 compiler/coreSyn/CoreLint.hs        |  2 +-
 compiler/coreSyn/CoreUtils.hs       | 55 +++++++++++++++++++++----------------
 compiler/simplCore/CSE.hs           | 10 ++++---
 compiler/simplCore/SimplUtils.hs    |  4 +--
 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 3dca78e..5ae7a59 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 913dda3..7030e39 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 a30c695..c43cbb7 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 ccc8a56..6bb290e 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 ce48c11..31b0a5a 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'])



More information about the ghc-commits mailing list