Zap usage info in CSE (Trac #10218)
authorSimon Peyton Jones <simonpj@microsoft.com>
Tue, 14 Apr 2015 08:20:42 +0000 (09:20 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 14 Apr 2015 08:22:00 +0000 (09:22 +0100)
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.)

compiler/basicTypes/Demand.hs
compiler/basicTypes/Id.hs
compiler/basicTypes/IdInfo.hs
compiler/simplCore/CSE.hs
compiler/simplCore/SetLevels.hs
compiler/stranal/DmdAnal.hs
testsuite/tests/simplCore/should_compile/EvalTest.hs
testsuite/tests/stranal/should_run/T10218.hs [new file with mode: 0644]
testsuite/tests/stranal/should_run/T10218.stdout [new file with mode: 0644]
testsuite/tests/stranal/should_run/all.T

index 9aa3b8f..5ffcb3d 100644 (file)
@@ -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
index 2a97445..a3ed5b9 100644 (file)
@@ -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]
index a54aeff..4c069ea 100644 (file)
@@ -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
index c43cbb7..fa517c2 100644 (file)
@@ -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]
index 0d7ba70..de02e27 100644 (file)
@@ -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
 
 {-
index 24ca3ed..bf6ca7d 100644 (file)
@@ -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)
index 8ce80ae..dbaba05 100644 (file)
@@ -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
diff --git a/testsuite/tests/stranal/should_run/T10218.hs b/testsuite/tests/stranal/should_run/T10218.hs
new file mode 100644 (file)
index 0000000..572c6fd
--- /dev/null
@@ -0,0 +1,18 @@
+{-# 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
diff --git a/testsuite/tests/stranal/should_run/T10218.stdout b/testsuite/tests/stranal/should_run/T10218.stdout
new file mode 100644 (file)
index 0000000..8351c19
--- /dev/null
@@ -0,0 +1 @@
+14
index 7f64f85..8a82ce8 100644 (file)
@@ -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, [''])