Add a final demand analyzer run right before TidyCorewip/T11731

in order to have precise used-once information in the exported
strictness signatures, as well as precise used-once information on
thunks. This avoids the bad effects of #11731.

The subsequent worker-wrapper pass is responsible for removing the
demand environment part of the strictness signature. It does not run
after the final demand analyzer pass, so remove this also in CoreTidy.

The subsequent worker-wrapper pass is also responsible for removing
used-once-information from the demands and strictness signatures, as
these might not be preserved by the simplifier. This is _not_ done by
CoreTidy, because we _do_ want this information, as produced by the last
round of the demand analyzer, to be available to the code generator.

7 files changed, 170 insertions, 45 deletions

diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs
index 4159dd67cf..928b0381d5 100644
--- a/compiler/basicTypes/Demand.hs
+++ b/compiler/basicTypes/Demand.hs
@@ -5,7 +5,7 @@
 \section[Demand]{@Demand@: A decoupled implementation of a demand domain}
 -}
 
-{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-}
+{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, RecordWildCards #-}
 
 module Demand (
         StrDmd, UseDmd(..), Count(..),
@@ -37,7 +37,7 @@ module Demand (
         appIsBottom, isBottomingSig, pprIfaceStrictSig,
         trimCPRInfo, returnsCPR_maybe,
         StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig,
-        isTopSig, splitStrictSig, increaseStrictSigArity,
+        isTopSig, hasDemandEnvSig, splitStrictSig, increaseStrictSigArity,
 
         seqDemand, seqDemandList, seqDmdType, seqStrictSig,
 
@@ -52,7 +52,8 @@ module Demand (
         trimToType, TypeShape(..),
 
         useCount, isUsedOnce, reuseEnv,
-        killUsageDemand, killUsageSig, zapUsageDemand,
+        killUsageDemand, killUsageSig, zapUsageDemand, zapUsageEnvSig,
+        zapUsedOnceDemand, zapUsedOnceSig,
         strictifyDictDmd
 
      ) where
@@ -1677,6 +1678,9 @@ increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res))
 isTopSig :: StrictSig -> Bool
 isTopSig (StrictSig ty) = isTopDmdType ty
 
+hasDemandEnvSig :: StrictSig -> Bool
+hasDemandEnvSig (StrictSig (DmdType env _ _)) = not (isEmptyVarEnv env)
+
 isBottomingSig :: StrictSig -> Bool
 -- True if the signature diverges or throws an exception
 isBottomingSig (StrictSig (DmdType _ _ res)) = isBotRes res
@@ -1861,9 +1865,31 @@ of absence or one-shot information altogether.  This is only used for performanc
 tests, to see how important they are.
 -}
 
+zapUsageEnvSig :: StrictSig -> StrictSig
+-- Remove the usage environment from the demand
+zapUsageEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r
+
 zapUsageDemand :: Demand -> Demand
 -- Remove the usage info, but not the strictness info, from the demand
-zapUsageDemand = kill_usage (True, True)
+zapUsageDemand = kill_usage $ KillFlags
+    { kf_abs         = True
+    , kf_used_once   = True
+    , kf_called_once = True
+    }
+
+-- | Remove all 1* information (but not C1 information) from the demand
+zapUsedOnceDemand :: Demand -> Demand
+zapUsedOnceDemand = kill_usage $ KillFlags
+    { kf_abs         = False
+    , kf_used_once   = True
+    , kf_called_once = False
+    }
+
+-- | Remove all 1* information (but not C1 information) from the strictness
+--   signature
+zapUsedOnceSig :: StrictSig -> StrictSig
+zapUsedOnceSig (StrictSig (DmdType env ds r))
+    = StrictSig (DmdType env (map zapUsedOnceDemand ds) r)
 
 killUsageDemand :: DynFlags -> Demand -> Demand
 -- See Note [Killing usage information]
@@ -1877,35 +1903,39 @@ 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)
+data KillFlags = KillFlags
+    { kf_abs         :: Bool
+    , kf_used_once   :: Bool
+    , kf_called_once :: 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)
+  | not kf_abs && not kf_used_once = Nothing
+  | otherwise                      = Just (KillFlags {..})
   where
-    kill_abs      = gopt Opt_KillAbsence dflags
-    kill_one_shot = gopt Opt_KillOneShot dflags
+    kf_abs         = gopt Opt_KillAbsence dflags
+    kf_used_once   = gopt Opt_KillOneShot dflags
+    kf_called_once = kf_used_once
 
 kill_usage :: KillFlags -> Demand -> Demand
 kill_usage kfs (JD {sd = s, ud = u}) = JD {sd = s, ud = zap_musg kfs u}
 
 zap_musg :: KillFlags -> ArgUse -> ArgUse
-zap_musg (kill_abs, _) Abs
-  | kill_abs  = useTop
-  | otherwise = Abs
-zap_musg kfs (Use c u) = Use (zap_count kfs c) (zap_usg kfs u)
-
-zap_count :: KillFlags -> Count -> Count
-zap_count (_, kill_one_shot) c
-  | kill_one_shot = Many
-  | otherwise     = c
+zap_musg kfs Abs
+  | kf_abs kfs = useTop
+  | otherwise  = Abs
+zap_musg kfs (Use c u)
+  | kf_used_once kfs = Use Many (zap_usg kfs u)
+  | otherwise        = Use c    (zap_usg kfs u)
 
 zap_usg :: KillFlags -> UseDmd -> UseDmd
-zap_usg kfs (UCall c u) = UCall (zap_count kfs c) (zap_usg kfs u)
-zap_usg kfs (UProd us)  = UProd (map (zap_musg kfs) us)
-zap_usg _   u           = u
+zap_usg kfs (UCall c u)
+    | kf_called_once kfs = UCall Many (zap_usg kfs u)
+    | otherwise          = UCall c    (zap_usg kfs u)
+zap_usg kfs (UProd us)   = UProd (map (zap_musg kfs) us)
+zap_usg _   u            = u
 
 -- If the argument is a used non-newtype dictionary, give it strict
 -- demand. Also split the product type & demand and recur in order to
diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs
index e55259b007..d5b78986ae 100644
--- a/compiler/basicTypes/Id.hs
+++ b/compiler/basicTypes/Id.hs
@@ -47,8 +47,9 @@ module Id (
         setIdExported, setIdNotExported,
         globaliseId, localiseId,
         setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
-        zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapFragileIdInfo,
-        zapIdStrictness,
+        zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo,
+        zapIdUsedOnceInfo,
+        zapFragileIdInfo, zapIdStrictness,
         transferPolyIdInfo,
 
         -- ** Predicates on Ids
@@ -785,6 +786,12 @@ zapIdDemandInfo = zapInfo zapDemandInfo
 zapIdUsageInfo :: Id -> Id
 zapIdUsageInfo = zapInfo zapUsageInfo
 
+zapIdUsageEnvInfo :: Id -> Id
+zapIdUsageEnvInfo = zapInfo zapUsageEnvInfo
+
+zapIdUsedOnceInfo :: Id -> Id
+zapIdUsedOnceInfo = zapInfo zapUsedOnceInfo
+
 {-
 Note [transferPolyIdInfo]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs
index fd61a9c6b9..849aea3ff8 100644
--- a/compiler/basicTypes/IdInfo.hs
+++ b/compiler/basicTypes/IdInfo.hs
@@ -24,7 +24,7 @@ module IdInfo (
 
         -- ** Zapping various forms of Info
         zapLamInfo, zapFragileInfo,
-        zapDemandInfo, zapUsageInfo,
+        zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo,
 
         -- ** The ArityInfo type
         ArityInfo,
@@ -470,6 +470,19 @@ zapDemandInfo info = Just (info {demandInfo = topDmd})
 zapUsageInfo :: IdInfo -> Maybe IdInfo
 zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)})
 
+-- | Remove usage environment info from the strictness signature on the 'IdInfo'
+zapUsageEnvInfo :: IdInfo -> Maybe IdInfo
+zapUsageEnvInfo info
+    | hasDemandEnvSig (strictnessInfo info)
+    = Just (info {strictnessInfo = zapUsageEnvSig (strictnessInfo info)})
+    | otherwise
+    = Nothing
+
+zapUsedOnceInfo :: IdInfo -> Maybe IdInfo
+zapUsedOnceInfo info
+    = Just $ info { strictnessInfo = zapUsedOnceSig    (strictnessInfo info)
+                  , demandInfo     = zapUsedOnceDemand (demandInfo     info) }
+
 zapFragileInfo :: IdInfo -> Maybe IdInfo
 -- ^ Zap info that depends on free variables
 zapFragileInfo info
diff --git a/compiler/coreSyn/CoreTidy.hs b/compiler/coreSyn/CoreTidy.hs
index aed4e214ad..782e11a42a 100644
--- a/compiler/coreSyn/CoreTidy.hs
+++ b/compiler/coreSyn/CoreTidy.hs
@@ -18,6 +18,7 @@ import CoreSyn
 import CoreArity
 import Id
 import IdInfo
+import Demand ( zapUsageEnvSig )
 import Type( tidyType, tidyTyCoVarBndr )
 import Coercion( tidyCo )
 import Var
@@ -187,6 +188,8 @@ tidyLetBndr rec_tidy_env env@(tidy_env, var_env) (id,rhs)
         --
         -- Similarly for the demand info - on a let binder, this tells
         -- CorePrep to turn the let into a case.
+        -- But: Remove the usage demand here
+        --      (See Note [Zapping DmdEnv after Demand Analyzer] in WorkWrap)
         --
         -- Similarly arity info for eta expansion in CorePrep
         --
@@ -196,7 +199,7 @@ tidyLetBndr rec_tidy_env env@(tidy_env, var_env) (id,rhs)
         new_info = vanillaIdInfo
                     `setOccInfo`        occInfo old_info
                     `setArityInfo`      exprArity rhs
-                    `setStrictnessInfo` strictnessInfo old_info
+                    `setStrictnessInfo` zapUsageEnvSig (strictnessInfo old_info)
                     `setDemandInfo`     demandInfo old_info
                     `setInlinePragInfo` inlinePragInfo old_info
                     `setUnfoldingInfo`  new_unf
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
index 98bcf2ad91..1ff0cee4f3 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -319,6 +319,11 @@ getCoreToDo dflags
             [simpl_phase 0 ["post-late-ww"] max_iter]
           ),
 
+        -- Final run of the demand_analyser, ensures that one-shot thunks are
+        -- really really one-shot thunks. Only needed if the demand analyser
+        -- has run at all. See Note [Final Demand Analyser run] in DmdAnal
+        runWhen (strictness || late_dmd_anal) CoreDoStrictness,
+
         maybe_rule_check (Phase 0)
      ]
 
diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs
index 20f65d5904..4d3fd09f09 100644
--- a/compiler/stranal/DmdAnal.hs
+++ b/compiler/stranal/DmdAnal.hs
@@ -1331,4 +1331,32 @@ of the Id, and start from "bottom".  Nowadays the Id can have a current
 strictness, because interface files record strictness for nested bindings.
 To know when we are in the first iteration, we look at the ae_virgin
 field of the AnalEnv.
+
+
+Note [Final Demand Analyser run]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Some of the information that the demand analyser determines is not always
+preserved by the simplifier, for example, the simplifier will happily rewrite
+  \y [Demand=1*U] let x = y in x + x
+to
+  \y [Demand=1*U] y + y
+which is quite a lie.
+
+The once-used information is (currently) only used by the code generator, though. So we
+ * do not bother keeping this information up-to-date in the simplifier, or
+   removing it after the demand analyser is done (keeping in mind not to
+   critically rely on this information in, say, the simplifier).
+   It should still be fine to use this as in heuristics, e.g. when deciding to
+   inline things, as the data will usually be correct.
+ * Just before TidyCore, we add a pass of the demand analyse, without
+   subsequent worker/wrapper and simplifier, right before TidyCore.
+   This way, correct information  finds its way into the module interface
+   (strictness signatures!) and the code generator (single-entry thunks!)
+
+Note that the single-call information (C1(..)) can be relied upon, as the
+simplifier tends to be very careful about not duplicating actual function
+calls.
+
+Also see #11731.
 -}
diff --git a/compiler/stranal/WorkWrap.hs b/compiler/stranal/WorkWrap.hs
index 7fde65f7a0..e557f44906 100644
--- a/compiler/stranal/WorkWrap.hs
+++ b/compiler/stranal/WorkWrap.hs
@@ -16,7 +16,6 @@ import IdInfo
 import UniqSupply
 import BasicTypes
 import DynFlags
-import VarEnv           ( isEmptyVarEnv )
 import Demand
 import WwLib
 import Util
@@ -107,7 +106,10 @@ wwExpr _      _ e@(Lit  {}) = return e
 wwExpr _      _ e@(Var  {}) = return e
 
 wwExpr dflags fam_envs (Lam binder expr)
-  = Lam binder <$> wwExpr dflags fam_envs expr
+  = Lam new_binder <$> wwExpr dflags fam_envs expr
+  where new_binder | isId binder = zapIdUsedOnceInfo binder
+                   | otherwise   = binder
+  -- See Note [Zapping Used Once info in WorkWrap]
 
 wwExpr dflags fam_envs (App f a)
   = App <$> wwExpr dflags fam_envs f <*> wwExpr dflags fam_envs a
@@ -125,11 +127,16 @@ wwExpr dflags fam_envs (Let bind expr)
 wwExpr dflags fam_envs (Case expr binder ty alts) = do
     new_expr <- wwExpr dflags fam_envs expr
     new_alts <- mapM ww_alt alts
-    return (Case new_expr binder ty new_alts)
+    let new_binder = zapIdUsedOnceInfo binder
+      -- See Note [Zapping Used Once info in WorkWrap]
+    return (Case new_expr new_binder ty new_alts)
   where
     ww_alt (con, binders, rhs) = do
         new_rhs <- wwExpr dflags fam_envs rhs
-        return (con, binders, new_rhs)
+        let new_binders = [ if isId b then zapIdUsedOnceInfo b else b
+                          | b <- binders ]
+           -- See Note [Zapping Used Once info in WorkWrap]
+        return (con, new_binders, new_rhs)
 
 {-
 ************************************************************************
@@ -279,9 +286,7 @@ tryWW dflags fam_envs is_rec fn_id rhs
         -- No point in worker/wrappering if the thing is never inlined!
         -- Because the no-inline prag will prevent the wrapper ever
         -- being inlined at a call site.
-        --
-        -- Furthermore, don't even expose strictness info
-  = return [ (fn_id, rhs) ]
+  = return [ (new_fn_id, rhs) ]
 
   | not loop_breaker
   , Just stable_unf <- certainlyWillInline dflags fn_unf
@@ -304,24 +309,58 @@ tryWW dflags fam_envs is_rec fn_id rhs
     fn_info      = idInfo fn_id
     inline_act   = inlinePragmaActivation (inlinePragInfo fn_info)
     fn_unf       = unfoldingInfo fn_info
+    (wrap_dmds, res_info) = splitStrictSig (strictnessInfo fn_info)
 
-        -- In practice it always will have a strictness
-        -- signature, even if it's a uninformative one
-    strict_sig  = strictnessInfo fn_info
-    StrictSig (DmdType env wrap_dmds res_info) = strict_sig
-
-        -- new_fn_id has the DmdEnv zapped.
-        --      (a) it is never used again
-        --      (b) it wastes space
-        --      (c) it becomes incorrect as things are cloned, because
-        --          we don't push the substitution into it
-    new_fn_id | isEmptyVarEnv env = fn_id
-              | otherwise         = fn_id `setIdStrictness`
-                                     mkClosedStrictSig wrap_dmds res_info
+    new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id)
+        -- See Note [Zapping DmdEnv after Demand Analyzer] and
+        -- See Note [Zapping Used Once info in WorkWrap]
 
     is_fun    = notNull wrap_dmds
     is_thunk  = not is_fun && not (exprIsHNF rhs)
 
+{-
+Note [Zapping DmdEnv after Demand Analyzer]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In the worker-wrapper pass we zap the DmdEnv.
+
+Why?
+ (a) it is never used again
+ (b) it wastes space
+ (c) it becomes incorrect as things are cloned, because
+     we don't push the substitution into it
+
+Why here?
+ * Because we don’t want to do it in the Demand Analyzer, as we never know
+   there when we are doing the last pass.
+ * We want them to be still there at the end of DmdAnal, so that
+   -ddump-str-anal contains them.
+ * We don’t want a second pass just for that.
+ * WorkWrap looks at all bindings anyways.
+
+We also need to do it in TidyCore to clean up after the final,
+worker/wrapper-less run of the demand analyser.
+
+Note [Zapping Used Once info in WorkWrap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In the worker-wrapper pass we zap the used once info in demands and in
+strictness signatures.
+
+Why?
+ * The simplifier may happen to transform code in a way that invalidates the
+   data (see #11731 for an example).
+ * It is not used in later passes, up to code generation.
+
+So as the data is useless and possibly wrong, we want to remove it. The most
+convenient place to do that is the worker wrapper phase, as it runs after every
+run of the demand analyser besides the very last one (which is the one where we
+want to _keep_ the info for the code generator).
+
+We do not do it in the demand analyser for the same reasons outlined in
+Note [Zapping DmdEnv after Demand Analyzer] above.
+-}
+
 
 ---------------------
 splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> DmdResult -> CoreExpr