Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : new-demand
http://hackage.haskell.org/trac/ghc/changeset/2bed340c84b852ebda7d68b139d23f7e20d4f75e >--------------------------------------------------------------- commit 2bed340c84b852ebda7d68b139d23f7e20d4f75e Author: Ilya Sergey <[email protected]> Date: Tue Aug 14 17:31:59 2012 +0100 zapping demand info bu fixed >--------------------------------------------------------------- compiler/basicTypes/Id.lhs | 2 +- compiler/basicTypes/IdInfo.lhs | 12 ++++++------ compiler/simplCore/FloatOut.lhs | 8 ++++++-- compiler/simplCore/SetLevels.lhs | 7 +++++-- compiler/simplCore/Simplify.lhs | 1 + 5 files changed, 19 insertions(+), 11 deletions(-) diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index b319052..912700d 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -698,7 +698,7 @@ zapLamIdInfo :: Id -> Id zapLamIdInfo = zapInfo zapLamInfo zapDemandIdInfo :: Id -> Id -zapDemandIdInfo = zapInfo zapDemandInfo +zapDemandIdInfo = zapInfo nd_zapDemandInfo zapFragileIdInfo :: Id -> Id zapFragileIdInfo = zapInfo zapFragileInfo diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index 178fbd6..a7f5336 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -556,11 +556,11 @@ instance Outputable LBVarInfo where -- -- > (\x1. \x2. e) arg1 zapLamInfo :: IdInfo -> Maybe IdInfo -zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand}) - | is_safe_occ occ && is_safe_dmd demand +zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand, nd_demandInfo = ndemand}) + | is_safe_occ occ && is_safe_dmd demand && nd_is_safe_dmd ndemand = Nothing | otherwise - = Just (info {occInfo = safe_occ, demandInfo = Nothing}) + = Just (info {occInfo = safe_occ, demandInfo = Nothing, nd_demandInfo = ND.top}) where -- The "unsafe" occ info is the ones that say I'm not in a lambda -- because that might not be true for an unsaturated lambda @@ -573,6 +573,8 @@ zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand}) is_safe_dmd Nothing = True is_safe_dmd (Just dmd) = not (isStrictDmd dmd) + + nd_is_safe_dmd ndmd = not (ND.isStrictDmd ndmd) \end{code} \begin{code} @@ -583,9 +585,7 @@ zapDemandInfo info@(IdInfo {demandInfo = dmd}) | otherwise = Nothing nd_zapDemandInfo :: IdInfo -> Maybe IdInfo -nd_zapDemandInfo info@(IdInfo {nd_demandInfo = dmd}) - | ND.isTop dmd = Just (info {nd_demandInfo = ND.top}) - | otherwise = Nothing +nd_zapDemandInfo info = Just (info {nd_demandInfo = ND.top}) \end{code} \begin{code} diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs index 18fc9b4..ede6b7a 100644 --- a/compiler/simplCore/FloatOut.lhs +++ b/compiler/simplCore/FloatOut.lhs @@ -358,8 +358,12 @@ Here y is demanded. If we float it outside the lazy 'x=..' then we'd have to zap its demand info, and it may never be restored. So at a 'let' we leave the binding right where the are unless -the binding will escape a value lambda. That's what the -partitionByMajorLevel does in the floatExpr (Let ...) case. +the binding will escape a value lambda, e.g. + +(\x -> let y = fac 100 in y) + +That's what the partitionByMajorLevel does in the floatExpr (Let ...) +case. Notice, though, that we must take care to drop any bindings from the body of the let that depend on the staying-put bindings. diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index ba85d03..2ec4c67 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -1119,7 +1119,9 @@ cloneVar :: LevelEnv -> Var -> Level -> LvlM (LevelEnv, Var) cloneVar env v dest_lvl -- Works for Ids, TyVars and CoVars = do { u <- getUniqueM ; let (subst', v1) = cloneBndr (le_subst env) u v - v2 = if isId v1 then zapDemandIdInfo v1 else v1 + v2 = if isId v1 + then (nd_zapDemandIdInfo . zapDemandIdInfo) v1 + else v1 env' = extendCloneLvlEnv dest_lvl env subst' [(v,v2)] ; return (env', v2) } @@ -1132,7 +1134,8 @@ cloneRecVars env vs dest_lvl -- Works for CoVars too (since cloneRecIdBndrs does us <- getUniqueSupplyM let (subst', vs1) = cloneRecIdBndrs (le_subst env) us vs - vs2 = map zapDemandIdInfo vs1 -- Note [Zapping the demand info] + -- Note [Zapping the demand info] + vs2 = map (nd_zapDemandIdInfo . zapDemandIdInfo) vs1 env' = extendCloneLvlEnv dest_lvl env subst' (vs `zip` vs2) return (env', vs2) \end{code} diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 5c8e19d..3df4bef 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -462,6 +462,7 @@ prepareRhs top_lvl env id (Cast rhs co) -- Note [Float coercions] sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info `nd_setStrictnessInfo` nd_strictnessInfo info `setDemandInfo` demandInfo info + `nd_setDemandInfo` nd_demandInfo info info = idInfo id prepareRhs top_lvl env0 _ rhs0 _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
