Commit d261d4cb authored by Simon Peyton Jones's avatar Simon Peyton Jones

Zap usage info in CSE (Trac #10218)

Trac #10218 reports a subtle bug that turned out to be:

- CSE invalidated the usage information computed
  by earlier demand analysis, by increasing sharing

- that made a single-entry thunk into a multi-entry thunk

- and with -feager-blackholing, that led to <<loop>>

The patch fixes it by making the CSE pass zap usage information for
let-bound identifiers.   It can be restored by -flate-dmd-anal.

(But making -flate-dmd-anal the default needs some careful work;
see Trac #7782.)
parent 919b5117
......@@ -48,8 +48,8 @@ module Demand (
argOneShots, argsOneShots,
trimToType, TypeShape(..),
isSingleUsed, reuseEnv, zapDemand, zapStrictSig,
isSingleUsed, reuseEnv,
killUsageDemand, killUsageSig, zapUsageDemand,
strictifyDictDmd
) where
......@@ -1714,21 +1714,34 @@ of arguments, says conservatively if the function is going to diverge
or not.
Zap absence or one-shot information, under control of flags
Note [Killing usage information]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The flags -fkill-one-shot and -fkill-absence let you switch off the generation
of absence or one-shot information altogether. This is only used for performance
tests, to see how important they are.
-}
zapDemand :: DynFlags -> Demand -> Demand
zapDemand dflags dmd
| Just kfs <- killFlags dflags = zap_dmd kfs dmd
zapUsageDemand :: Demand -> Demand
-- Remove the usage info, but not the strictness info, from the demand
zapUsageDemand = kill_usage (True, True)
killUsageDemand :: DynFlags -> Demand -> Demand
-- See Note [Killing usage information]
killUsageDemand dflags dmd
| Just kfs <- killFlags dflags = kill_usage kfs dmd
| otherwise = dmd
zapStrictSig :: DynFlags -> StrictSig -> StrictSig
zapStrictSig dflags sig@(StrictSig (DmdType env ds r))
| Just kfs <- killFlags dflags = StrictSig (DmdType env (map (zap_dmd kfs) ds) r)
killUsageSig :: DynFlags -> StrictSig -> StrictSig
-- See Note [Killing usage information]
killUsageSig dflags sig@(StrictSig (DmdType env ds r))
| Just kfs <- killFlags dflags = StrictSig (DmdType env (map (kill_usage kfs) ds) r)
| otherwise = sig
type KillFlags = (Bool, Bool)
killFlags :: DynFlags -> Maybe KillFlags
-- See Note [Killing usage information]
killFlags dflags
| not kill_abs && not kill_one_shot = Nothing
| otherwise = Just (kill_abs, kill_one_shot)
......@@ -1736,8 +1749,8 @@ killFlags dflags
kill_abs = gopt Opt_KillAbsence dflags
kill_one_shot = gopt Opt_KillOneShot dflags
zap_dmd :: KillFlags -> Demand -> Demand
zap_dmd kfs (JD {strd = s, absd = u}) = JD {strd = s, absd = zap_musg kfs u}
kill_usage :: KillFlags -> Demand -> Demand
kill_usage kfs (JD {strd = s, absd = u}) = JD {strd = s, absd = zap_musg kfs u}
zap_musg :: KillFlags -> MaybeUsed -> MaybeUsed
zap_musg (kill_abs, _) Abs
......
......@@ -45,8 +45,9 @@ module Id (
setIdExported, setIdNotExported,
globaliseId, localiseId,
setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
zapLamIdInfo, zapDemandIdInfo, zapFragileIdInfo, transferPolyIdInfo,
zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapFragileIdInfo,
zapIdStrictness,
transferPolyIdInfo,
-- ** Predicates on Ids
isImplicitId, isDeadBinder,
......@@ -733,8 +734,11 @@ zapLamIdInfo = zapInfo zapLamInfo
zapFragileIdInfo :: Id -> Id
zapFragileIdInfo = zapInfo zapFragileInfo
zapDemandIdInfo :: Id -> Id
zapDemandIdInfo = zapInfo zapDemandInfo
zapIdDemandInfo :: Id -> Id
zapIdDemandInfo = zapInfo zapDemandInfo
zapIdUsageInfo :: Id -> Id
zapIdUsageInfo = zapInfo zapUsageInfo
{-
Note [transferPolyIdInfo]
......
......@@ -24,7 +24,7 @@ module IdInfo (
-- ** Zapping various forms of Info
zapLamInfo, zapFragileInfo,
zapDemandInfo,
zapDemandInfo, zapUsageInfo,
-- ** The ArityInfo type
ArityInfo,
......@@ -475,10 +475,14 @@ zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand})
is_safe_dmd dmd = not (isStrictDmd dmd)
-- | Remove demand info on the 'IdInfo' if it is present, otherwise return @Nothing@
-- | Remove all demand info on the 'IdInfo'
zapDemandInfo :: IdInfo -> Maybe IdInfo
zapDemandInfo info = Just (info {demandInfo = topDmd})
-- | Remove usage (but not strictness) info on the 'IdInfo'
zapUsageInfo :: IdInfo -> Maybe IdInfo
zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)})
zapFragileInfo :: IdInfo -> Maybe IdInfo
-- ^ Zap info that depends on free variables
zapFragileInfo info
......
......@@ -12,7 +12,7 @@ module CSE (cseProgram) where
import CoreSubst
import Var ( Var )
import Id ( Id, idType, idInlineActivation, zapIdOccInfo )
import Id ( Id, idType, idInlineActivation, zapIdOccInfo, zapIdUsageInfo )
import CoreUtils ( mkAltExpr
, exprIsTrivial
, stripTicksE, stripTicksT, stripTicksTopE, mkTick, mkTicks )
......@@ -158,27 +158,27 @@ cseProgram binds = snd (mapAccumL cseBind emptyCSEnv binds)
cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
cseBind env (NonRec b e)
= (env2, NonRec b' e')
= (env2, NonRec b'' e')
where
(env1, b') = addBinder env b
(env2, e') = cseRhs env1 (b',e)
(env2, (b'', e')) = cseRhs env1 (b',e)
cseBind env (Rec pairs)
= (env2, Rec (bs' `zip` es'))
= (env2, Rec pairs')
where
(bs,es) = unzip pairs
(env1, bs') = addRecBinders env bs
(env2, es') = mapAccumL cseRhs env1 (bs' `zip` es)
(env2, pairs') = mapAccumL cseRhs env1 (bs' `zip` es)
cseRhs :: CSEnv -> (OutBndr, InExpr) -> (CSEnv, OutExpr)
cseRhs :: CSEnv -> (OutBndr, InExpr) -> (CSEnv, (OutBndr, OutExpr))
cseRhs env (id',rhs)
= case lookupCSEnv env rhs'' of
Nothing
| always_active -> (extendCSEnv env rhs' id', rhs')
| otherwise -> (env, rhs')
| always_active -> (extendCSEnv env rhs' id', (zapped_id, rhs'))
| otherwise -> (env, (id', rhs'))
Just id
| always_active -> (extendCSSubst env id' id, mkTicks ticks $ Var id)
| otherwise -> (env, mkTicks ticks $ Var id)
| always_active -> (extendCSSubst env id' id, (id', mkTicks ticks $ Var id))
| otherwise -> (env, (id', mkTicks ticks $ Var id))
-- In the Just case, we have
-- x = rhs
-- ...
......@@ -188,6 +188,17 @@ cseRhs env (id',rhs)
-- that subsequent uses of x' are replaced with x,
-- See Trac #5996
where
zapped_id = zapIdUsageInfo id'
-- Putting the Id into the environment makes it possible that
-- it'll become shared more than it is now, which would
-- invalidate (the usage part of) its demand info. This caused
-- Trac #100218.
-- Easiest thing is to zap the usage info; subsequently
-- performing late demand-analysis will restore it. Don't zap
-- the strictness info; it's not necessary to do so, and losing
-- it is bad for performance if you don't do late demand
-- analysis
rhs' = cseExpr env rhs
ticks = stripTicksT tickishFloatable rhs'
......@@ -222,7 +233,7 @@ 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
in Let bind' (cseExpr env' e)
cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty alts'
cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr''' ty alts'
where
alts' = cseAlts env2 scrut' bndr bndr'' alts
(env1, bndr') = addBinder env bndr
......@@ -230,7 +241,7 @@ cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty alts'
-- The swizzling from Note [Case binders 2] may
-- cause a dead case binder to be alive, so we
-- play safe here and bring them all to life
(env2, scrut') = cseRhs env1 (bndr'', scrut)
(env2, (bndr''', scrut')) = cseRhs env1 (bndr'', scrut)
-- Note [CSE for case expressions]
cseAlts :: CSEnv -> OutExpr -> InBndr -> InBndr -> [InAlt] -> [OutAlt]
......
......@@ -1099,7 +1099,7 @@ add_id id_env (v, v1)
zap_demand_info :: Var -> Var
zap_demand_info v
| isId v = zapDemandIdInfo v
| isId v = zapIdDemandInfo v
| otherwise = v
{-
......
......@@ -1116,7 +1116,7 @@ findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)
findBndrDmd env arg_of_dfun dmd_ty id
= (dmd_ty', dmd')
where
dmd' = zapDemand (ae_dflags env) $
dmd' = killUsageDemand (ae_dflags env) $
strictify $
trimToType starting_dmd (findTypeShape fam_envs id_ty)
......@@ -1138,7 +1138,7 @@ findBndrDmd env arg_of_dfun dmd_ty id
set_idStrictness :: AnalEnv -> Id -> StrictSig -> Id
set_idStrictness env id sig
= setIdStrictness id (zapStrictSig (ae_dflags env) sig)
= setIdStrictness id (killUsageSig (ae_dflags env) sig)
dumpStrSig :: CoreProgram -> SDoc
dumpStrSig binds = vcat (map printId ids)
......
......@@ -2,9 +2,9 @@
-- for 'rght' was initially determined (correctly) to be
-- strictly demanded, but the FloatOut pass made it lazy
--
-- The test compiles the program and greps for the
-- The test compiles the program and greps for the
-- binding of 'rght' to check that it is marked strict
-- somethign like this:
-- something like this:
-- rght [Dmd=Just S] :: EvalTest.AList a
module EvalTest where
......
{-# OPTIONS_GHC -feager-blackholing #-}
module Main where
{-# NOINLINE foo #-}
foo :: Bool -> Int -> Int -> Int
foo True _ x = 1
foo False _ x = x+1
{-# NOINLINE bar #-}
bar :: Int -> (Int,Int)
bar x = let y1 = x * 2
y2 = x * 2
in (foo False y1 y2,foo False y2 y1)
main = print (fst p + snd p)
where
p = bar 3
......@@ -9,3 +9,4 @@ test('T2756b', normal, compile_and_run, [''])
test('T7649', normal, compile_and_run, [''])
test('T9254', normal, compile_and_run, [''])
test('T10148', normal, compile_and_run, [''])
test('T10218', normal, compile_and_run, [''])
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