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 39344fc..38c1f58 100644 (file)
--- a/compiler/simplCore/CSE.lhs
+++ b/compiler/simplCore/CSE.lhs
@@ -21,8 +21,11 @@ import CoreLint              ( showPass, endPass )
 import Outputable
 import StaticFlags     ( opt_PprStyle_Debug )
 import BasicTypes      ( isAlwaysActive )
-import Util            ( mapAccumL, lengthExceeds )
+import Util            ( lengthExceeds )
 import UniqFM
+import FastString
+
+import Data.List
 \end{code}
 
 
@@ -108,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.
 
-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 
 
@@ -162,7 +165,7 @@ Not CSE-ing inside INLINE also solves an annoying bug in CSE. Consider
 a worker/wrapper, in which the worker has turned into a single variable:
        $wf = h
        f = \x -> ...$wf...
-Now CSE may transoform to
+Now CSE may transform to
        f = \x -> ...h...
 But the WorkerInfo for f still says $wf, which is now dead!  This won't
 happen now that we don't look inside INLINEs (which wrappers are).
@@ -185,7 +188,7 @@ cseProgram dflags binds
     }
 
 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
-cseBinds env []     = []
+cseBinds _   []     = []
 cseBinds env (b:bs) = (b':bs')
                    where
                      (env1, b') = cseBind  env  b
@@ -198,6 +201,7 @@ cseBind env (Rec pairs)  = let (env', pairs') = mapAccumL do_one env 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))
@@ -207,10 +211,10 @@ do_one env (id, 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 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'
@@ -218,11 +222,11 @@ tryForCSE env expr     = case lookupCSEnv env expr' of
                         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 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
@@ -235,7 +239,9 @@ cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr' ty (cseAlts env' scrut
                                     (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]
@@ -254,7 +260,7 @@ cseAlts env scrut' bndr bndr' alts
                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)
@@ -294,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
 
+emptyCSEnv :: CSEnv
 emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
 
 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr
@@ -303,15 +310,17 @@ lookupCSEnv (CS cs _ _) expr
        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
 
+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)
 
+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
@@ -324,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
 
+lookupSubst :: CSEnv -> Id -> Id
 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)
-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 )