Ticket #5996: 0001-Whitespace-layout-only-in-simplCore-CSE.patch

File 0001-Whitespace-layout-only-in-simplCore-CSE.patch, 19.6 KB (added by michalt, 3 years ago)
  • compiler/simplCore/CSE.lhs

    From 6abe52739ffd8ea8e8d8b18f65d98fb88783e88c Mon Sep 17 00:00:00 2001
    From: Michal Terepeta <[email protected]>
    Date: Sun, 11 Dec 2011 09:20:26 +0100
    Subject: [PATCH 1/3] Whitespace/layout only in simplCore/CSE.
    
    ---
     compiler/simplCore/CSE.lhs |  274 +++++++++++++++++++++-----------------------
     1 files changed, 132 insertions(+), 142 deletions(-)
    
    diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs
    index 4a92f81..a1f6d8f 100644
    a b  
    44\section{Common subexpression}
    55
    66\begin{code}
    7 {-# OPTIONS -fno-warn-tabs #-}
    8 -- The above warning supression flag is a temporary kludge.
    9 -- While working on this module you are encouraged to remove it and
    10 -- detab the module (please do the detabbing in a separate patch). See
    11 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
    12 -- for details
    13 
    14 module CSE (
    15         cseProgram
    16     ) where
     7module CSE ( cseProgram ) where
    178
    189#include "HsVersions.h"
    1910
    module CSE ( 
    2617-- NB: when you remove this, also delete hashExpr from CoreUtils
    2718#ifdef OLD_CSENV_REP
    2819import CoreUtils        ( exprIsBig, hashExpr, eqExpr )
    29 import StaticFlags      ( opt_PprStyle_Debug )
    30 import Util             ( lengthExceeds )
     20import StaticFlags      ( opt_PprStyle_Debug )
     21import Util             ( lengthExceeds )
    3122import UniqFM
    3223import FastString
    3324#else
    import TrieMap 
    3526#endif
    3627
    3728import CoreSubst
    38 import Var              ( Var )
    39 import Id               ( Id, idType, idInlineActivation, zapIdOccInfo )
    40 import CoreUtils        ( mkAltExpr
    41                         , exprIsTrivial, exprIsCheap )
    42 import DataCon          ( isUnboxedTupleCon )
    43 import Type             ( tyConAppArgs )
     29import Var              ( Var )
     30import Id               ( Id, idType, idInlineActivation, zapIdOccInfo )
     31import CoreUtils        ( mkAltExpr, exprIsTrivial, exprIsCheap )
     32import DataCon          ( isUnboxedTupleCon )
     33import Type             ( tyConAppArgs )
    4434import CoreSyn
    4535import Outputable
    46 import BasicTypes       ( isAlwaysActive )
     36import BasicTypes       ( isAlwaysActive )
    4737
    4838import Data.List
    4939\end{code}
    5040
    5141
    52                         Simple common sub-expression
    53                         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     42                        Simple common sub-expression
     43                        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    5444When we see
    55         x1 = C a b
    56         x2 = C x1 b
     45        x1 = C a b
     46        x2 = C x1 b
    5747we build up a reverse mapping:   C a b  -> x1
    58                                 C x1 b -> x2
     48                                C x1 b -> x2
    5949and apply that to the rest of the program.
    6050
    6151When we then see
    62         y1 = C a b
    63         y2 = C y1 b
     52        y1 = C a b
     53        y2 = C y1 b
    6454we replace the C a b with x1.  But then we *dont* want to
    6555add   x1 -> y1  to the mapping.  Rather, we want the reverse, y1 -> x1
    6656so that a subsequent binding
    67         y2 = C y1 b
    68 will get transformed to C x1 b, and then to x2. 
     57        y2 = C y1 b
     58will get transformed to C x1 b, and then to x2.
    6959
    7060So we carry an extra var->var substitution which we apply *before* looking up in the
    7161reverse mapping.
    Note [Shadowing] 
    7565~~~~~~~~~~~~~~~~
    7666We have to be careful about shadowing.
    7767For example, consider
    78         f = \x -> let y = x+x in
    79                       h = \x -> x+x
    80                   in ...
     68        f = \x -> let y = x+x in
     69                      h = \x -> x+x
     70                  in ...
    8171
    8272Here we must *not* do CSE on the inner x+x!  The simplifier used to guarantee no
    8373shadowing, but it doesn't any more (it proved too hard), so we clone as we go.
    Note [Case binders 1] 
    8777~~~~~~~~~~~~~~~~~~~~~~
    8878Consider
    8979
    90         f = \x -> case x of wild {
    91                         (a:as) -> case a of wild1 {
    92                                     (p,q) -> ...(wild1:as)...
     80        f = \x -> case x of wild {
     81                        (a:as) -> case a of wild1 {
     82                                    (p,q) -> ...(wild1:as)...
    9383
    9484Here, (wild1:as) is morally the same as (a:as) and hence equal to wild.
    9585But that's not quite obvious.  In general we want to keep it as (wild1:as),
    to try to replaces uses of 'a' with uses of 'wild1' 
    10292Note [Case binders 2]
    10393~~~~~~~~~~~~~~~~~~~~~~
    10494Consider
    105         case (h x) of y -> ...(h x)...
     95        case (h x) of y -> ...(h x)...
    10696
    10797We'd like to replace (h x) in the alternative, by y.  But because of
    10898the preceding [Note: case binders 1], we only want to add the mapping
    109         scrutinee -> case binder
     99        scrutinee -> case binder
    110100to the reverse CSE mapping if the scrutinee is a non-trivial expression.
    111101(If the scrutinee is a simple variable we want to add the mapping
    112         case binder -> scrutinee
     102        case binder -> scrutinee
    113103to the substitution
    114104
    115105Note [Unboxed tuple case binders]
    116106~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    117107Consider
    118         case f x of t { (# a,b #) ->
    119         case ... of
    120           True -> f x
    121           False -> 0 }
     108        case f x of t { (# a,b #) ->
     109        case ... of
     110          True -> f x
     111          False -> 0 }
    122112
    123113We must not replace (f x) by t, because t is an unboxed-tuple binder.
    124114Instead, we shoudl replace (f x) by (# a,b #).  That is, the "reverse mapping" is
    125         f x --> (# a,b #)
     115        f x --> (# a,b #)
    126116That is why the CSEMap has pairs of expressions.
    127117
    128118Note [CSE for INLINE and NOINLINE]
    129119~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    130120We are careful to do no CSE inside functions that the user has marked as
    131 INLINE or NOINLINE.  In terms of Core, that means 
     121INLINE or NOINLINE.  In terms of Core, that means
    132122
    133         a) we do not do CSE inside an InlineRule
     123        a) we do not do CSE inside an InlineRule
    134124
    135         b) we do not do CSE on the RHS of a binding b=e
    136            unless b's InlinePragma is AlwaysActive
     125        b) we do not do CSE on the RHS of a binding b=e
     126           unless b's InlinePragma is AlwaysActive
    137127
    138128Here's why (examples from Roman Leshchinskiy).  Consider
    139129
    140         yes :: Int
    141         {-# NOINLINE yes #-}
    142         yes = undefined
     130        yes :: Int
     131        {-# NOINLINE yes #-}
     132        yes = undefined
    143133
    144         no :: Int
    145         {-# NOINLINE no #-}
    146         no = undefined
     134        no :: Int
     135        {-# NOINLINE no #-}
     136        no = undefined
    147137
    148         foo :: Int -> Int -> Int
    149         {-# NOINLINE foo #-}
    150         foo m n = n
     138        foo :: Int -> Int -> Int
     139        {-# NOINLINE foo #-}
     140        foo m n = n
    151141
    152         {-# RULES "foo/no" foo no = id #-}
     142        {-# RULES "foo/no" foo no = id #-}
    153143
    154         bar :: Int -> Int
    155         bar = foo yes
     144        bar :: Int -> Int
     145        bar = foo yes
    156146
    157147We do not expect the rule to fire.  But if we do CSE, then we get
    158148yes=no, and the rule does fire.  Worse, whether we get yes=no or
    no=yes depends on the order of the definitions. 
    161151In general, CSE should probably never touch things with INLINE pragmas
    162152as this could lead to surprising results.  Consider
    163153
    164         {-# INLINE foo #-}
    165         foo = <rhs>
     154        {-# INLINE foo #-}
     155        foo = <rhs>
    166156
    167         {-# NOINLINE bar #-}
    168         bar = <rhs>     -- Same rhs as foo
     157        {-# NOINLINE bar #-}
     158        bar = <rhs>     -- Same rhs as foo
    169159
    170160If CSE produces
    171         foo = bar
     161        foo = bar
    172162then foo will never be inlined (when it should be); but if it produces
    173         bar = foo
     163        bar = foo
    174164bar will be inlined (when it should not be). Even if we remove INLINE foo,
    175165we'd still like foo to be inlined if rhs is small. This won't happen
    176166with foo = bar.
    177167
    178168Not CSE-ing inside INLINE also solves an annoying bug in CSE. Consider
    179169a worker/wrapper, in which the worker has turned into a single variable:
    180         $wf = h
    181         f = \x -> ...$wf...
     170        $wf = h
     171        f = \x -> ...$wf...
    182172Now CSE may transform to
    183         f = \x -> ...h...
     173        f = \x -> ...h...
    184174But the WorkerInfo for f still says $wf, which is now dead!  This won't
    185175happen now that we don't look inside INLINEs (which wrappers are).
    186176
    187177
    188178%************************************************************************
    189 %*                                                                      *
     179%*                                                                      *
    190180\section{Common subexpression}
    191 %*                                                                      *
     181%*                                                                      *
    192182%************************************************************************
    193183
    194184\begin{code}
    cseProgram binds = cseBinds emptyCSEnv binds 
    198188cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
    199189cseBinds _   []     = []
    200190cseBinds env (b:bs) = (b':bs')
    201                     where
    202                       (env1, b') = cseBind  env  b
    203                       bs'        = cseBinds env1 bs
     191                    where
     192                      (env1, b') = cseBind  env  b
     193                      bs'        = cseBinds env1 bs
    204194
    205195cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
    206 cseBind env (NonRec b e) 
     196cseBind env (NonRec b e)
    207197  = (env2, NonRec b' e')
    208198  where
    209199    (env1, b') = addBinder env b
    cseBind env (Rec pairs) 
    219209cseRhs :: CSEnv -> (OutBndr, InExpr) -> (CSEnv, OutExpr)
    220210cseRhs env (id',rhs)
    221211  = case lookupCSEnv env rhs' of
    222         Just other_expr     -> (env,                             other_expr)
    223         Nothing             -> (addCSEnvItem env rhs' (Var id'), rhs')
     212        Just other_expr     -> (env,                             other_expr)
     213        Nothing             -> (addCSEnvItem env rhs' (Var id'), rhs')
    224214  where
    225215    rhs' | isAlwaysActive (idInlineActivation id') = cseExpr env rhs
    226          | otherwise                               = rhs
    227                 -- See Note [CSE for INLINE and NOINLINE]
     216         | otherwise                               = rhs
     217                -- See Note [CSE for INLINE and NOINLINE]
    228218
    229219tryForCSE :: CSEnv -> InExpr -> OutExpr
    230220tryForCSE env expr
    231   | exprIsTrivial expr'                   = expr'       -- No point
     221  | exprIsTrivial expr'                   = expr'    -- No point
    232222  | Just smaller <- lookupCSEnv env expr' = smaller
    233223  | otherwise                             = expr'
    234224  where
    cseExpr :: CSEnv -> InExpr -> OutExpr 
    238228cseExpr env (Type t)               = Type (substTy (csEnvSubst env) t)
    239229cseExpr env (Coercion c)           = Coercion (substCo (csEnvSubst env) c)
    240230cseExpr _   (Lit lit)              = Lit lit
    241 cseExpr env (Var v)                = lookupSubst env v
    242 cseExpr env (App f a)              = App (cseExpr env f) (tryForCSE env a)
    243 cseExpr env (Tick t e)           = Tick t (cseExpr env e)
     231cseExpr env (Var v)                = lookupSubst env v
     232cseExpr env (App f a)              = App (cseExpr env f) (tryForCSE env a)
     233cseExpr env (Tick t e)             = Tick t (cseExpr env e)
    244234cseExpr env (Cast e co)            = Cast (cseExpr env e) (substCo (csEnvSubst env) co)
    245 cseExpr env (Lam b e)              = let (env', b') = addBinder env b
    246                                      in Lam b' (cseExpr env' e)
    247 cseExpr env (Let bind e)           = let (env', bind') = cseBind env bind
    248                                      in Let bind' (cseExpr env' e)
     235cseExpr env (Lam b e)              = let (env', b') = addBinder env b
     236                                     in Lam b' (cseExpr env' e)
     237cseExpr env (Let bind e)           = let (env', bind') = cseBind env bind
     238                                     in Let bind' (cseExpr env' e)
    249239cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty alts'
    250                                    where
     240                                   where
    251241                                     alts' = cseAlts env' scrut' bndr bndr'' alts
    252                                      scrut' = tryForCSE env scrut
    253                                      (env', bndr') = addBinder env bndr
    254                                      bndr'' = zapIdOccInfo bndr'
    255                                         -- The swizzling from Note [Case binders 2] may
    256                                         -- cause a dead case binder to be alive, so we
    257                                         -- play safe here and bring them all to life
     242                                     scrut' = tryForCSE env scrut
     243                                     (env', bndr') = addBinder env bndr
     244                                     bndr'' = zapIdOccInfo bndr'
     245                                        -- The swizzling from Note [Case binders 2] may
     246                                        -- cause a dead case binder to be alive, so we
     247                                        -- play safe here and bring them all to life
    258248
    259249cseAlts :: CSEnv -> OutExpr -> InBndr -> InBndr -> [InAlt] -> [OutAlt]
    260250
    261251cseAlts env scrut' bndr _bndr' [(DataAlt con, args, rhs)]
    262252  | isUnboxedTupleCon con
    263         -- Unboxed tuples are special because the case binder isn't
    264         -- a real value.  See Note [Unboxed tuple case binders]
     253        -- Unboxed tuples are special because the case binder isn't
     254        -- a real value.  See Note [Unboxed tuple case binders]
    265255  = [(DataAlt con, args'', tryForCSE new_env rhs)]
    266256  where
    267257    (env', args') = addBinders env args
    268     args'' = map zapIdOccInfo args'     -- They should all be ids
    269         -- Same motivation for zapping as [Case binders 2] only this time
    270         -- it's Note [Unboxed tuple case binders]
     258    args'' = map zapIdOccInfo args'    -- They should all be ids
     259        -- Same motivation for zapping as [Case binders 2] only this time
     260        -- it's Note [Unboxed tuple case binders]
    271261    new_env | exprIsCheap scrut' = env'
    272             | otherwise          = extendCSEnv env' scrut' tup_value
     262            | otherwise          = extendCSEnv env' scrut' tup_value
    273263    tup_value = mkAltExpr (DataAlt con) args'' (tyConAppArgs (idType bndr))
    274264
    275265cseAlts env scrut' bndr bndr' alts
    276266  = map cse_alt alts
    277267  where
    278268    (con_target, alt_env)
    279         = case scrut' of
    280             Var v' -> (v',     extendCSSubst env bndr v')       -- See Note [Case binders 1]
    281                                                                 -- map: bndr -> v'
     269        = case scrut' of
     270            Var v' -> (v',     extendCSSubst env bndr v')       -- See Note [Case binders 1]
     271                                                                -- map: bndr -> v'
    282272
    283             _      ->  (bndr', extendCSEnv env scrut' (Var  bndr')) -- See Note [Case binders 2]
    284                                                                     -- map: scrut' -> bndr'
     273            _      ->  (bndr', extendCSEnv env scrut' (Var  bndr')) -- See Note [Case binders 2]
     274                                                                    -- map: scrut' -> bndr'
    285275
    286276    arg_tys = tyConAppArgs (idType bndr)
    287277
    288278    cse_alt (DataAlt con, args, rhs)
    289         | not (null args)
    290                 -- Don't try CSE if there are no args; it just increases the number
    291                 -- of live vars.  E.g.
    292                 --      case x of { True -> ....True.... }
    293                 -- Don't replace True by x! 
    294                 -- Hence the 'null args', which also deal with literals and DEFAULT
    295         = (DataAlt con, args', tryForCSE new_env rhs)
    296         where
    297           (env', args') = addBinders alt_env args
    298           new_env       = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys)
    299                                            (Var con_target)
     279        | not (null args)
     280                -- Don't try CSE if there are no args; it just increases the number
     281                -- of live vars.  E.g.
     282                --      case x of { True -> ....True.... }
     283                -- Don't replace True by x!
     284                -- Hence the 'null args', which also deal with literals and DEFAULT
     285        = (DataAlt con, args', tryForCSE new_env rhs)
     286        where
     287          (env', args') = addBinders alt_env args
     288          new_env       = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys)
     289                                           (Var con_target)
    300290
    301291    cse_alt (con, args, rhs)
    302         = (con, args', tryForCSE env' rhs)
    303         where
    304           (env', args') = addBinders alt_env args
     292        = (con, args', tryForCSE env' rhs)
     293        where
     294          (env', args') = addBinders alt_env args
    305295\end{code}
    306296
    307297
    308298%************************************************************************
    309 %*                                                                      *
     299%*                                                                      *
    310300\section{The CSE envt}
    311 %*                                                                      *
     301%*                                                                      *
    312302%************************************************************************
    313303
    314304\begin{code}
    315 type InExpr  = CoreExpr         -- Pre-cloning
     305type InExpr  = CoreExpr         -- Pre-cloning
    316306type InBndr  = CoreBndr
    317307type InAlt   = CoreAlt
    318308
    319 type OutExpr  = CoreExpr        -- Post-cloning
     309type OutExpr  = CoreExpr        -- Post-cloning
    320310type OutBndr  = CoreBndr
    321311type OutAlt   = CoreAlt
    322312
    type OutAlt = CoreAlt 
    325315data CSEnv  = CS { cs_map    :: CSEMap
    326316                 , cs_subst  :: Subst }
    327317
    328 type CSEMap = UniqFM [(OutExpr, OutExpr)]       -- This is the reverse mapping
    329         -- It maps the hash-code of an expression e to list of (e,e') pairs
    330         -- This means that it's good to replace e by e'
    331         -- INVARIANT: The expr in the range has already been CSE'd
     318type CSEMap = UniqFM [(OutExpr, OutExpr)]       -- This is the reverse mapping
     319        -- It maps the hash-code of an expression e to list of (e,e') pairs
     320        -- This means that it's good to replace e by e'
     321        -- INVARIANT: The expr in the range has already been CSE'd
    332322
    333323emptyCSEnv :: CSEnv
    334324emptyCSEnv = CS { cs_map = emptyUFM, cs_subst = emptySubst }
    emptyCSEnv = CS { cs_map = emptyUFM, cs_subst = emptySubst } 
    336326lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
    337327lookupCSEnv (CS { cs_map = oldmap, cs_subst = sub}) expr
    338328  = case lookupUFM oldmap (hashExpr expr) of
    339                 Nothing -> Nothing
    340                 Just pairs -> lookup_list pairs
     329                Nothing -> Nothing
     330                Just pairs -> lookup_list pairs
    341331  where
    342332    in_scope = substInScope sub
    343333
    344334  -- In this lookup we use full expression equality
    345335  -- Reason: when expressions differ we generally find out quickly
    346336  --         but I found that cheapEqExpr was saying (\x.x) /= (\y.y),
    347   --         and this kind of thing happened in real programs
     337  --         and this kind of thing happened in real programs
    348338    lookup_list :: [(OutExpr,OutExpr)] -> Maybe OutExpr
    349     lookup_list ((e,e'):es) 
     339    lookup_list ((e,e'):es)
    350340      | eqExpr in_scope e expr = Just e'
    351       | otherwise                        = lookup_list es
     341      | otherwise                        = lookup_list es
    352342    lookup_list []                       = Nothing
    353343
    354344addCSEnvItem :: CSEnv -> OutExpr -> OutExpr -> CSEnv
    355345addCSEnvItem env expr expr' | exprIsBig expr = env
    356                             | otherwise      = extendCSEnv env expr expr'
     346                            | otherwise      = extendCSEnv env expr expr'
    357347   -- We don't try to CSE big expressions, because they are expensive to compare
    358348   -- (and are unlikely to be the same anyway)
    359349
    extendCSEnv cse@(CS { cs_map = oldmap }) expr expr' 
    362352  = cse { cs_map = addToUFM_C combine oldmap hash [(expr, expr')] }
    363353  where
    364354    hash = hashExpr expr
    365     combine old new 
    366         = WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
    367         where
    368           result = new ++ old
    369           short_msg = ptext (sLit "extendCSEnv: long list, length") <+> int (length result)
    370           long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result
    371                    | otherwise          = empty
     355    combine old new
     356        = WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
     357        where
     358          result = new ++ old
     359          short_msg = ptext (sLit "extendCSEnv: long list, length") <+> int (length result)
     360          long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result
     361                   | otherwise          = empty
    372362
    373363#else
    374364------------ NEW ----------------
    emptyCSEnv :: CSEnv 
    380370emptyCSEnv = CS { cs_map = emptyCoreMap, cs_subst = emptySubst }
    381371
    382372lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
    383 lookupCSEnv (CS { cs_map = csmap }) expr 
     373lookupCSEnv (CS { cs_map = csmap }) expr
    384374  = case lookupCoreMap csmap expr of
    385375      Just (_,e) -> Just e
    386376      Nothing    -> Nothing
    extendCSSubst :: CSEnv -> Id -> Id -> CSEnv 
    408398extendCSSubst cse x y = cse { cs_subst = extendIdSubst (cs_subst cse) x (Var y) }
    409399
    410400addBinder :: CSEnv -> Var -> (CSEnv, Var)
    411 addBinder cse v = (cse { cs_subst = sub' }, v') 
     401addBinder cse v = (cse { cs_subst = sub' }, v')
    412402                where
    413403                  (sub', v') = substBndr (cs_subst cse) v
    414404
    415405addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])
    416 addBinders cse vs = (cse { cs_subst = sub' }, vs') 
     406addBinders cse vs = (cse { cs_subst = sub' }, vs')
    417407                where
    418408                  (sub', vs') = substBndrs (cs_subst cse) vs
    419409
    420410addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
    421 addRecBinders cse vs = (cse { cs_subst = sub' }, vs') 
     411addRecBinders cse vs = (cse { cs_subst = sub' }, vs')
    422412                where
    423413                  (sub', vs') = substRecBndrs (cs_subst cse) vs
    424414\end{code}