Don't import FastString in HsVersions.h

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

diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs
index e0584ad..38c1f58 100644 (file)
--- a/compiler/simplCore/CSE.lhs
+++ b/compiler/simplCore/CSE.lhs
@@ -4,13 +4,6 @@
 \section{Common subexpression}
 
 \begin{code}
 \section{Common subexpression}
 
 \begin{code}

-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-

 module CSE (
        cseProgram
     ) where
 module CSE (
        cseProgram
     ) where

@@ -30,6 +23,7 @@ import StaticFlags    ( opt_PprStyle_Debug )
 import BasicTypes      ( isAlwaysActive )
 import Util            ( lengthExceeds )
 import UniqFM
 import BasicTypes      ( isAlwaysActive )
 import Util            ( lengthExceeds )
 import UniqFM

+import FastString

 
 import Data.List
 \end{code}
 
 import Data.List
 \end{code}

@@ -117,8 +111,8 @@ Instead, we shoudl replace (f x) by (# a,b #).  That is, the "reverse mapping" i
        f x --> (# a,b #)
 That is why the CSEMap has pairs of expressions.
 
        f x --> (# a,b #)
 That is why the CSEMap has pairs of expressions.
 

-Note [INLINE and NOINLINE]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
+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 
 

@@ -194,7 +188,7 @@ cseProgram dflags binds
     }
 
 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
     }
 
 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]

-cseBinds env []     = []
+cseBinds _   []     = []

 cseBinds env (b:bs) = (b':bs')
                    where
                      (env1, b') = cseBind  env  b
 cseBinds env (b:bs) = (b':bs')
                    where
                      (env1, b') = cseBind  env  b

@@ -207,6 +201,7 @@ cseBind env (Rec pairs)  = let (env', pairs') = mapAccumL do_one env pairs
                           in (env', Rec pairs')
                         
 
                           in (env', Rec pairs')
                         
 

+do_one :: CSEnv -> (Id, CoreExpr) -> (CSEnv, (Id, CoreExpr))

 do_one env (id, rhs) 
   = case lookupCSEnv env rhs' of
        Just (Var other_id) -> (extendSubst env' id other_id,     (id', Var other_id))
 do_one env (id, rhs) 
   = case lookupCSEnv env rhs' of
        Just (Var other_id) -> (extendSubst env' id other_id,     (id', Var other_id))

@@ -216,10 +211,10 @@ do_one env (id, rhs)
     (env', id') = addBinder env id
     rhs' | isAlwaysActive (idInlinePragma id) = cseExpr env' rhs
         | otherwise                          = rhs
     (env', id') = addBinder env id
     rhs' | isAlwaysActive (idInlinePragma id) = cseExpr env' rhs
         | otherwise                          = rhs

-               -- See Note [INLINE and NOINLINE]
+               -- See Note [CSE for INLINE and NOINLINE]

 
 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
 
 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr

-tryForCSE env (Type t) = Type t
+tryForCSE _   (Type t) = Type t

 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'

@@ -227,11 +222,11 @@ tryForCSE env expr     = case lookupCSEnv env expr' of
                         expr' = cseExpr env expr
 
 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
                         expr' = cseExpr env expr
 
 cseExpr :: CSEnv -> CoreExpr -> CoreExpr

-cseExpr env (Type t)              = Type t
-cseExpr env (Lit lit)             = Lit lit
+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 env (Var v)               = Var (lookupSubst env v)
 cseExpr env (App f a)             = App (cseExpr env f) (tryForCSE env a)

-cseExpr evn (Note InlineMe e)     = Note InlineMe e    -- See Note [INLINE and NOINLINE]
+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

@@ -244,7 +239,9 @@ cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr' ty (cseAlts env' scrut
                                     (env', bndr') = addBinder env bndr
 
 
                                     (env', bndr') = addBinder env bndr
 
 

-cseAlts env scrut' bndr bndr' [(DataAlt con, args, rhs)]
+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]
   | isUnboxedTupleCon con
        -- Unboxed tuples are special because the case binder isn't
        -- a real values.  See [Note: unboxed tuple case binders]

@@ -263,7 +260,7 @@ cseAlts env scrut' bndr bndr' alts
                Var v' -> (v',    extendSubst env bndr v')      -- See [Note: case binder 1]
                                                                -- map: bndr -> v'
 
                Var v' -> (v',    extendSubst env bndr v')      -- See [Note: case binder 1]
                                                                -- map: bndr -> v'
 

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

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

@@ -303,6 +300,7 @@ type CSEMap = UniqFM [(CoreExpr, CoreExpr)] -- This is the reverse mapping
        -- This means that it's good to replace e by e'
        -- INVARIANT: The expr in the range has already been CSE'd
 
        -- This means that it's good to replace e by e'
        -- INVARIANT: The expr in the range has already been CSE'd
 

+emptyCSEnv :: CSEnv

 emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
 
 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr
 emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
 
 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr

@@ -312,15 +310,17 @@ lookupCSEnv (CS cs _ _) expr
        Just pairs -> lookup_list pairs expr
 
 lookup_list :: [(CoreExpr,CoreExpr)] -> CoreExpr -> Maybe CoreExpr
        Just pairs -> lookup_list pairs expr
 
 lookup_list :: [(CoreExpr,CoreExpr)] -> CoreExpr -> Maybe CoreExpr

-lookup_list [] expr = Nothing
+lookup_list [] _ = Nothing

 lookup_list ((e,e'):es) expr | cheapEqExpr e expr = Just e'
                             | otherwise          = lookup_list es expr
 
 lookup_list ((e,e'):es) expr | cheapEqExpr e expr = Just e'
                             | otherwise          = lookup_list es expr
 

+addCSEnvItem :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv

 addCSEnvItem env expr expr' | exprIsBig expr = env
                            | otherwise      = extendCSEnv env expr expr'
    -- We don't try to CSE big expressions, because they are expensive to compare
    -- (and are unlikely to be the same anyway)
 
 addCSEnvItem env expr expr' | exprIsBig expr = env
                            | otherwise      = extendCSEnv env expr expr'
    -- We don't try to CSE big expressions, because they are expensive to compare
    -- (and are unlikely to be the same anyway)
 

+extendCSEnv :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv

 extendCSEnv (CS cs in_scope sub) expr expr'
   = CS (addToUFM_C combine cs hash [(expr, expr')]) in_scope sub
   where
 extendCSEnv (CS cs in_scope sub) expr expr'
   = CS (addToUFM_C combine cs hash [(expr, expr')]) in_scope sub
   where

@@ -333,14 +333,16 @@ extendCSEnv (CS cs in_scope sub) expr expr'
          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
 

+lookupSubst :: CSEnv -> Id -> Id

 lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
                               Just y  -> y
                               Nothing -> x
 
 lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
                               Just y  -> y
                               Nothing -> x
 

+extendSubst :: CSEnv -> Id  -> Id -> CSEnv

 extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y)
 
 addBinder :: CSEnv -> Id -> (CSEnv, Id)
 extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y)
 
 addBinder :: CSEnv -> Id -> (CSEnv, Id)

-addBinder env@(CS cs in_scope sub) v
+addBinder (CS cs in_scope sub) v

   | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v)  sub,                    v)
   | isId v                           = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
   | otherwise                        = WARN( True, ppr v )
   | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v)  sub,                    v)
   | isId v                           = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
   | otherwise                        = WARN( True, ppr v )