Commit 3e9679af authored by Simon Peyton Jones's avatar Simon Peyton Jones

Merge branch 'master' of http://darcs.haskell.org/ghc

parents 64a27638 adc3fb88
......@@ -77,9 +77,11 @@ data CmmInfoTable
ClosureTypeInfo
| CmmNonInfoTable -- Procedure doesn't need an info table
-- | If the table is local, we don't export its identifier even if the corresponding Id is exported.
-- It's always safe to say 'False' here, but it might save symbols to say 'True'
-- | If the table is local, we don't export its identifier even if the
-- corresponding Id is exported. It's always safe to say 'False'
-- here, but it might save symbols to say 'True'
type LocalInfoTable = Bool
type HasStaticClosure = Bool
-- TODO: The GC target shouldn't really be part of CmmInfo
......
......@@ -367,7 +367,8 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
-- Note [Silly extra arguments]
(do { v <- newVar (idType bndr)
; let float = mkFloat False False v rhs2
; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })
; return ( addFloat floats2 float
, cpeEtaExpand arity (Var v)) })
-- Record if the binder is evaluated
-- and otherwise trim off the unfolding altogether
......@@ -655,7 +656,7 @@ cpeArg env is_strict arg arg_ty
{ v <- newVar arg_ty
; let arg3 = cpeEtaExpand (exprArity arg2) arg2
arg_float = mkFloat is_strict is_unlifted v arg3
; return (addFloat floats2 arg_float, Var v) } }
; return (addFloat floats2 arg_float, varToCoreExpr v) } }
where
is_unlifted = isUnLiftedType arg_ty
want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)
......
......@@ -13,7 +13,8 @@ module CSE (
import CoreSubst
import Var ( Var )
import Id ( Id, idType, idInlineActivation, zapIdOccInfo )
import CoreUtils ( hashExpr, eqExpr, exprIsBig, mkAltExpr, exprIsCheap )
import CoreUtils ( hashExpr, eqExpr, exprIsBig, mkAltExpr
, exprIsTrivial, exprIsCheap )
import DataCon ( isUnboxedTupleCon )
import Type ( tyConAppArgs )
import CoreSyn
......@@ -206,22 +207,21 @@ cseRhs env (id',rhs)
-- See Note [CSE for INLINE and NOINLINE]
tryForCSE :: CSEnv -> InExpr -> OutExpr
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'
where
expr' = cseExpr env expr
tryForCSE env expr
| exprIsTrivial expr' = expr' -- No point
| Just smaller <- lookupCSEnv env expr' = smaller
| otherwise = expr'
where
expr' = cseExpr env expr
cseExpr :: CSEnv -> InExpr -> OutExpr
cseExpr _ (Type t) = Type t
cseExpr _ (Coercion co) = Coercion co
cseExpr env (Type t) = Type (substTy (csEnvSubst env) t)
cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c)
cseExpr _ (Lit lit) = Lit lit
cseExpr env (Var v) = lookupSubst env v
cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
cseExpr env (Note n e) = Note n (cseExpr env e)
cseExpr env (Cast e co) = Cast (cseExpr env e) co
cseExpr env (Cast e co) = Cast (cseExpr env e) (substCo (csEnvSubst env) co)
cseExpr env (Lam b e) = let (env', b') = addBinder env b
in Lam b' (cseExpr env' e)
cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
......@@ -309,6 +309,9 @@ type CSEMap = UniqFM [(OutExpr, OutExpr)] -- This is the reverse mapping
emptyCSEnv :: CSEnv
emptyCSEnv = CS emptyUFM emptySubst
csEnvSubst :: CSEnv -> Subst
csEnvSubst (CS _ subst) = subst
lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
lookupCSEnv (CS cs sub) expr
= case lookupUFM cs (hashExpr expr) of
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment