projects
/
ghc-hetmet.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
9cc7aff
)
Fixed warnings in simplCore/CSE
author
Twan van Laarhoven
<twanvl@gmail.com>
Sat, 26 Jan 2008 23:39:18 +0000
(23:39 +0000)
committer
Twan van Laarhoven
<twanvl@gmail.com>
Sat, 26 Jan 2008 23:39:18 +0000
(23:39 +0000)
compiler/simplCore/CSE.lhs
patch
|
blob
|
history
diff --git
a/compiler/simplCore/CSE.lhs
b/compiler/simplCore/CSE.lhs
index
3bcc177
..
93b0b8d
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
@@
-194,7
+187,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
+200,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))
@@
-219,7
+213,7
@@
do_one env (id, rhs)
-- See Note [CSE for INLINE and NOINLINE]
tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
-- 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'
tryForCSE env expr = case lookupCSEnv env expr' of
Just smaller_expr -> smaller_expr
Nothing -> expr'
@@
-227,11
+221,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 env (Note InlineMe e) = Note InlineMe e -- See Note [CSE for 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
+238,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
+259,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
+299,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
+309,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
+332,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 )