Fix warnings

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

diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs
index 9b90220..5bec8f0 100644 (file)
--- a/compiler/simplCore/CSE.lhs
+++ b/compiler/simplCore/CSE.lhs
@@ -10,8 +10,8 @@ module CSE (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

-import Id              ( Id, idType, idInlinePragma, zapIdOccInfo )
-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 DataCon         ( isUnboxedTupleCon )
 import Type            ( tyConAppArgs )
 import CoreSyn

@@ -114,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

@@ -201,12 +201,13 @@ 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
 tryForCSE _   (Type t) = Type t
                -- See Note [CSE for INLINE and NOINLINE]
 
 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
 tryForCSE _   (Type t) = Type t

+tryForCSE _   (Coercion c) = Coercion c

 tryForCSE env expr     = case lookupCSEnv env expr' of
                            Just smaller_expr -> smaller_expr
                            Nothing           -> expr'
 tryForCSE env expr     = case lookupCSEnv env expr' of
                            Just smaller_expr -> smaller_expr
                            Nothing           -> expr'

@@ -215,10 +216,10 @@ tryForCSE env expr     = case lookupCSEnv env expr' of
 
 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
 cseExpr _   (Type t)               = Type t
 
 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
 cseExpr _   (Type t)               = Type t

+cseExpr _   (Coercion co)          = Coercion co

 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

@@ -302,15 +303,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

@@ -342,7 +347,7 @@ 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
   | otherwise                        = WARN( True, ppr v )
                                        (CS emptyUFM in_scope                 sub,                     v)
        -- This last case is the unusual situation where we have shadowing of