add -fsimpleopt-before-flatten

[ghc-hetmet.git] / compiler / simplCore / CSE.lhs

diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs
index 38c1f58..523431f 100644 (file)
--- a/compiler/simplCore/CSE.lhs
+++ b/compiler/simplCore/CSE.lhs
@@ -10,14 +10,12 @@ module CSE (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

-import DynFlags        ( DynFlag(..), DynFlags )
-import Id              ( Id, idType, idInlinePragma )
-import CoreUtils       ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap )
+import Id              ( Id, idType, idInlineActivation, zapIdOccInfo )
+import CoreUtils       ( hashExpr, eqExpr, exprIsBig, mkAltExpr, exprIsCheap )

 import DataCon         ( isUnboxedTupleCon )
 import Type            ( tyConAppArgs )
 import CoreSyn
 import VarEnv  
 import DataCon         ( isUnboxedTupleCon )
 import Type            ( tyConAppArgs )
 import CoreSyn
 import VarEnv  

-import CoreLint                ( showPass, endPass )

 import Outputable
 import StaticFlags     ( opt_PprStyle_Debug )
 import BasicTypes      ( isAlwaysActive )
 import Outputable
 import StaticFlags     ( opt_PprStyle_Debug )
 import BasicTypes      ( isAlwaysActive )

@@ -51,8 +49,8 @@ So we carry an extra var->var substitution which we apply *before* looking up in
 reverse mapping.
 
 
 reverse mapping.
 
 

-[Note: SHADOWING]
-~~~~~~~~~~~~~~~~~
+Note [Shadowing]
+~~~~~~~~~~~~~~~~

 We have to be careful about shadowing.
 For example, consider
        f = \x -> let y = x+x in
 We have to be careful about shadowing.
 For example, consider
        f = \x -> let y = x+x in

@@ -69,7 +67,7 @@ to run the substitution over types and IdInfo.  No no no.  Instead, we just thro
 (In fact, I think the simplifier does guarantee no-shadowing for type variables.)
 
 
 (In fact, I think the simplifier does guarantee no-shadowing for type variables.)
 
 

-[Note: case binders 1]
+Note [Case binders 1]

 ~~~~~~~~~~~~~~~~~~~~~~
 Consider
 
 ~~~~~~~~~~~~~~~~~~~~~~
 Consider
 

@@ -83,9 +81,9 @@ but for CSE purpose that's a bad idea.
 
 So we add the binding (wild1 -> a) to the extra var->var mapping.
 Notice this is exactly backwards to what the simplifier does, which is
 
 So we add the binding (wild1 -> a) to the extra var->var mapping.
 Notice this is exactly backwards to what the simplifier does, which is

-to try to replaces uses of a with uses of wild1
+to try to replaces uses of 'a' with uses of 'wild1'

 
 

-[Note: case binders 2]
+Note [Case binders 2]

 ~~~~~~~~~~~~~~~~~~~~~~
 Consider
        case (h x) of y -> ...(h x)...
 ~~~~~~~~~~~~~~~~~~~~~~
 Consider
        case (h x) of y -> ...(h x)...

@@ -98,7 +96,7 @@ to the reverse CSE mapping if the scrutinee is a non-trivial expression.
        case binder -> scrutinee 
 to the substitution
 
        case binder -> scrutinee 
 to the substitution
 

-[Note: unboxed tuple case binders]
+Note [Unboxed tuple case binders]

 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
        case f x of t { (# a,b #) -> 
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
        case f x of t { (# a,b #) -> 

@@ -116,7 +114,7 @@ Note [CSE for INLINE and NOINLINE]
 We are careful to do no CSE inside functions that the user has marked as
 INLINE or NOINLINE.  In terms of Core, that means 
 
 We are careful to do no CSE inside functions that the user has marked as
 INLINE or NOINLINE.  In terms of Core, that means 
 

-       a) we do not do CSE inside (Note InlineMe e)
+       a) we do not do CSE inside an InlineRule

 
        b) we do not do CSE on the RHS of a binding b=e
           unless b's InlinePragma is AlwaysActive
 
        b) we do not do CSE on the RHS of a binding b=e
           unless b's InlinePragma is AlwaysActive

@@ -178,14 +176,8 @@ happen now that we don't look inside INLINEs (which wrappers are).
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-cseProgram :: DynFlags -> [CoreBind] -> IO [CoreBind]
-
-cseProgram dflags binds
-  = do {
-       showPass dflags "Common sub-expression";
-       let { binds' = cseBinds emptyCSEnv binds };
-       endPass dflags "Common sub-expression"  Opt_D_dump_cse binds'   
-    }
+cseProgram :: [CoreBind] -> [CoreBind]
+cseProgram binds = cseBinds emptyCSEnv binds

 
 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
 cseBinds _   []     = []
 
 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
 cseBinds _   []     = []

@@ -209,8 +201,8 @@ do_one env (id, rhs)
        Nothing             -> (addCSEnvItem env' rhs' (Var id'), (id', rhs'))
   where
     (env', id') = addBinder env id
        Nothing             -> (addCSEnvItem env' rhs' (Var id'), (id', rhs'))
   where
     (env', id') = addBinder env id

-    rhs' | isAlwaysActive (idInlinePragma id) = cseExpr env' rhs
-        | otherwise                          = rhs
+    rhs' | isAlwaysActive (idInlineActivation id) = cseExpr env' rhs
+        | otherwise                              = rhs

                -- See Note [CSE for INLINE and NOINLINE]
 
 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
                -- See Note [CSE for INLINE and NOINLINE]
 
 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr

@@ -226,41 +218,46 @@ cseExpr _   (Type t)               = Type t
 cseExpr _   (Lit lit)              = Lit lit
 cseExpr env (Var v)               = Var (lookupSubst env v)
 cseExpr env (App f a)             = App (cseExpr env f) (tryForCSE env a)
 cseExpr _   (Lit lit)              = Lit lit
 cseExpr env (Var v)               = Var (lookupSubst env v)
 cseExpr env (App f a)             = App (cseExpr env f) (tryForCSE env a)

-cseExpr _   (Note InlineMe e)      = Note InlineMe e    -- See Note [CSE for INLINE and NOINLINE]

 cseExpr env (Note n e)            = Note n (cseExpr env e)
 cseExpr env (Cast e co)            = Cast (cseExpr env e) co
 cseExpr env (Lam b e)             = let (env', b') = addBinder env b
                                     in Lam b' (cseExpr env' e)
 cseExpr env (Let bind e)          = let (env', bind') = cseBind env bind
                                     in Let bind' (cseExpr env' e)
 cseExpr env (Note n e)            = Note n (cseExpr env e)
 cseExpr env (Cast e co)            = Cast (cseExpr env e) co
 cseExpr env (Lam b e)             = let (env', b') = addBinder env b
                                     in Lam b' (cseExpr env' e)
 cseExpr env (Let bind e)          = let (env', bind') = cseBind env bind
                                     in Let bind' (cseExpr env' e)

-cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr' ty (cseAlts env' scrut' bndr bndr' alts)
+cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty (cseAlts env' scrut' bndr bndr'' alts)

                                   where
                                     scrut' = tryForCSE env scrut
                                     (env', bndr') = addBinder env bndr
                                   where
                                     scrut' = tryForCSE env scrut
                                     (env', bndr') = addBinder env bndr

-
+                                    bndr'' = zapIdOccInfo bndr'
+                                       -- The swizzling from Note [Case binders 2] may
+                                       -- cause a dead case binder to be alive, so we
+                                       -- play safe here and bring them all to life

 
 cseAlts :: CSEnv -> CoreExpr -> CoreBndr -> CoreBndr -> [CoreAlt] -> [CoreAlt]
 
 cseAlts env scrut' bndr _bndr' [(DataAlt con, args, rhs)]
   | isUnboxedTupleCon con
        -- Unboxed tuples are special because the case binder isn't
 
 cseAlts :: CSEnv -> CoreExpr -> CoreBndr -> CoreBndr -> [CoreAlt] -> [CoreAlt]
 
 cseAlts env scrut' bndr _bndr' [(DataAlt con, args, rhs)]
   | isUnboxedTupleCon con
        -- Unboxed tuples are special because the case binder isn't

-       -- a real values.  See [Note: unboxed tuple case binders]
-  = [(DataAlt con, args', tryForCSE new_env rhs)]
+       -- a real value.  See Note [Unboxed tuple case binders]
+  = [(DataAlt con, args'', tryForCSE new_env rhs)]

   where
     (env', args') = addBinders env args
   where
     (env', args') = addBinders env args

+    args'' = map zapIdOccInfo args'    -- They should all be ids
+       -- Same motivation for zapping as [Case binders 2] only this time
+       -- it's Note [Unboxed tuple case binders]

     new_env | exprIsCheap scrut' = env'
            | otherwise          = extendCSEnv env' scrut' tup_value
     new_env | exprIsCheap scrut' = env'
            | otherwise          = extendCSEnv env' scrut' tup_value

-    tup_value = mkAltExpr (DataAlt con) args' (tyConAppArgs (idType bndr))
+    tup_value = mkAltExpr (DataAlt con) args'' (tyConAppArgs (idType bndr))

 
 cseAlts env scrut' bndr bndr' alts
   = map cse_alt alts
   where
     (con_target, alt_env)
        = case scrut' of
 
 cseAlts env scrut' bndr bndr' alts
   = map cse_alt alts
   where
     (con_target, alt_env)
        = case scrut' of

-               Var v' -> (v',    extendSubst env bndr v')      -- See [Note: case binder 1]
+               Var v' -> (v',     extendSubst env bndr v')     -- See Note [Case binders 1]

                                                                -- map: bndr -> v'
 
                                                                -- map: bndr -> v'
 

-               _      ->  (bndr', extendCSEnv env scrut' (Var  bndr')) -- See [Note: case binder 2]
+               _      ->  (bndr', extendCSEnv env scrut' (Var  bndr')) -- See Note [Case binders 2]

                                                                        -- map: scrut' -> bndr'
 
     arg_tys = tyConAppArgs (idType bndr)
                                                                        -- map: scrut' -> bndr'
 
     arg_tys = tyConAppArgs (idType bndr)

@@ -304,15 +301,19 @@ emptyCSEnv :: CSEnv
 emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
 
 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr
 emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
 
 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr

-lookupCSEnv (CS cs _ _) expr
+lookupCSEnv (CS cs in_scope _) expr

   = case lookupUFM cs (hashExpr expr) of
        Nothing -> Nothing
   = case lookupUFM cs (hashExpr expr) of
        Nothing -> Nothing

-       Just pairs -> lookup_list pairs expr
-
-lookup_list :: [(CoreExpr,CoreExpr)] -> CoreExpr -> Maybe CoreExpr
-lookup_list [] _ = Nothing
-lookup_list ((e,e'):es) expr | cheapEqExpr e expr = Just e'
-                            | otherwise          = lookup_list es expr
+       Just pairs -> lookup_list pairs
+  where
+  -- In this lookup we use full expression equality
+  -- Reason: when expressions differ we generally find out quickly
+  --         but I found that cheapEqExpr was saying (\x.x) /= (\y.y),
+  --        and this kind of thing happened in real programs
+    lookup_list :: [(CoreExpr,CoreExpr)] -> Maybe CoreExpr
+    lookup_list []                                   = Nothing
+    lookup_list ((e,e'):es) | eqExpr in_scope e expr = Just e'
+                           | otherwise              = lookup_list es

 
 addCSEnvItem :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv
 addCSEnvItem env expr expr' | exprIsBig expr = env
 
 addCSEnvItem :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv
 addCSEnvItem env expr expr' | exprIsBig expr = env

@@ -329,7 +330,7 @@ extendCSEnv (CS cs in_scope sub) expr expr'
        = WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
        where
          result = new ++ old
        = WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
        where
          result = new ++ old

-         short_msg = ptext SLIT("extendCSEnv: long list, length") <+> int (length result)
+         short_msg = ptext (sLit "extendCSEnv: long list, length") <+> int (length result)

          long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result 
                   | otherwise          = empty
 
          long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result 
                   | otherwise          = empty
 

@@ -349,7 +350,7 @@ addBinder (CS cs in_scope sub) v
                                        (CS emptyUFM in_scope                 sub,                     v)
        -- This last case is the unusual situation where we have shadowing of
        -- a type variable; we have to discard the CSE mapping
                                        (CS emptyUFM in_scope                 sub,                     v)
        -- This last case is the unusual situation where we have shadowing of
        -- a type variable; we have to discard the CSE mapping

-       -- See "IMPORTANT NOTE" at the top 
+       -- See Note [Shadowing]

   where
     v' = uniqAway in_scope v
 
   where
     v' = uniqAway in_scope v