The Big INLINE Patch: totally reorganise way that INLINE pragmas work

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

diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs
index 1386197..8c38661 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, zapIdOccInfo )
+import Id              ( Id, idType, idInlineActivation, zapIdOccInfo )

 import CoreUtils       ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap )
 import DataCon         ( isUnboxedTupleCon )
 import Type            ( tyConAppArgs )
 import CoreSyn
 import VarEnv  
 import CoreUtils       ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap )
 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

@@ -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,7 +218,6 @@ 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
 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

@@ -247,7 +238,7 @@ 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 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]
+       -- a real value.  See Note [Unboxed tuple case binders]

   = [(DataAlt con, args'', tryForCSE new_env rhs)]
   where
     (env', args') = addBinders env args
   = [(DataAlt con, args'', tryForCSE new_env rhs)]
   where
     (env', args') = addBinders env args

@@ -350,12 +341,12 @@ extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y)
 addBinder :: CSEnv -> Id -> (CSEnv, Id)
 addBinder (CS cs in_scope sub) v
   | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v)  sub,                    v)
 addBinder :: CSEnv -> Id -> (CSEnv, Id)
 addBinder (CS cs in_scope sub) v
   | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v)  sub,                    v)

-  | isIdVar v                        = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
+  | isId v                           = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')

   | otherwise                        = WARN( True, ppr 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
   | otherwise                        = WARN( True, ppr 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

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

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