Do absence analysis on stable unfoldings

Ticket #18638 showed that Very Bad Things happen if we fail
to do absence analysis on stable unfoldings.  It's all described
in Note [Absence analysis for stable unfoldings and RULES].

I'm a bit surprised this hasn't bitten us before. Fortunately
the fix is pretty simple.

6 files changed, 147 insertions, 10 deletions

diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs
index d3cbe267f6..374f7cfec8 100644
--- a/compiler/GHC/Core/FVs.hs
+++ b/compiler/GHC/Core/FVs.hs
@@ -34,9 +34,10 @@ module GHC.Core.FVs (
         bndrRuleAndUnfoldingVarsDSet,
         idFVs,
         idRuleVars, idRuleRhsVars, stableUnfoldingVars,
-        ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
+        ruleFreeVars, rulesFreeVars,
         rulesFreeVarsDSet, mkRuleInfo,
         ruleLhsFreeIds, ruleLhsFreeIdsList,
+        ruleRhsFreeVars, ruleRhsFreeIds,
 
         expr_fvs,
 
@@ -524,6 +525,14 @@ ruleLhsFVIds (BuiltinRule {}) = emptyFV
 ruleLhsFVIds (Rule { ru_bndrs = bndrs, ru_args = args })
   = filterFV isLocalId $ addBndrs bndrs (exprs_fvs args)
 
+ruleRhsFreeIds :: CoreRule -> VarSet
+-- ^ This finds all locally-defined free Ids on the left hand side of a rule
+-- and returns them as a non-deterministic set
+ruleRhsFreeIds (BuiltinRule {}) = emptyVarSet
+ruleRhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
+  = fvVarSet $ filterFV isLocalId $
+     addBndrs bndrs $ exprs_fvs args
+
 {-
 Note [Rule free var hack]  (Not a hack any more)
 ~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index 083566ac78..53cd8a9a78 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/compiler/GHC/Core/Opt/DmdAnal.hs
@@ -23,6 +23,7 @@ import GHC.Core.Multiplicity ( scaledThing )
 import GHC.Core.Seq     ( seqBinds )
 import GHC.Utils.Outputable
 import GHC.Types.Var.Env
+import GHC.Types.Var.Set
 import GHC.Types.Basic
 import Data.List        ( mapAccumL )
 import GHC.Core.DataCon
@@ -32,6 +33,7 @@ import GHC.Types.Id.Info
 import GHC.Core.Utils
 import GHC.Core.TyCon
 import GHC.Core.Type
+import GHC.Core.FVs      ( exprFreeIds, ruleRhsFreeIds )
 import GHC.Core.Coercion ( Coercion, coVarsOfCo )
 import GHC.Core.FamInstEnv
 import GHC.Utils.Misc
@@ -552,7 +554,9 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs
             -- See Note [Demand signatures are computed for a threshold demand based on idArity]
             = mkRhsDmd env rhs_arity rhs
 
-    (DmdType rhs_fv rhs_dmds rhs_div, rhs') = dmdAnal env rhs_dmd rhs
+    (rhs_dmd_ty, rhs') = dmdAnal env rhs_dmd rhs
+    DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty
+
     sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)
 
     -- See Note [Aggregated demand for cardinality]
@@ -560,10 +564,23 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs
                 Just bs -> reuseEnv (delVarEnvList rhs_fv bs)
                 Nothing -> rhs_fv
 
+    rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` extra_fvs
+
     -- See Note [Lazy and unleashable free variables]
-    (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1
+    (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv2
     is_thunk = not (exprIsHNF rhs) && not (isJoinId id)
 
+    -- Find the RHS free vars of the unfoldings and RULES
+    -- See Note [Absence analysis for stable unfoldings and RULES]
+    extra_fvs = foldr (unionVarSet . ruleRhsFreeIds) unf_fvs $
+                idCoreRules id
+
+    unf = realIdUnfolding id
+    unf_fvs | isStableUnfolding unf
+            , Just unf_body <- maybeUnfoldingTemplate unf
+            = exprFreeIds unf_body
+            | otherwise = emptyVarSet
+
 -- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for
 -- unleashing on the given function's @rhs@, by creating
 -- a call demand of @rhs_arity@
@@ -799,6 +816,43 @@ Fortunately, GHC.Core.Opt.Arity gives 'foo' arity 2, which is enough for LetDown
 forward plusInt's demand signature, and all is well (see Note [Newtype arity] in
 GHC.Core.Opt.Arity)! A small example is the test case NewtypeArity.
 
+Note [Absence analysis for stable unfoldings and RULES]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Ticket #18638 shows that it's really important to do absence analysis
+for stable unfoldings. Consider
+
+   g = blah
+
+   f = \x.  ...no use of g....
+   {- f's stable unfolding is f = \x. ...g... -}
+
+If f is ever inlined we use 'g'. But f's current RHS makes no use
+of 'g', so if we don't look at the unfolding we'll mark g as Absent,
+and transform to
+
+   g = error "Entered absent value"
+   f = \x. ...
+   {- f's stable unfolding is f = \x. ...g... -}
+
+Now if f is subsequently inlined, we'll use 'g' and ... disaster.
+
+SOLUTION: if f has a stable unfolding, adjust its DmdEnv (the demands
+on its free variables) so that no variable mentioned in its unfolding
+is Absent.  This is done by the function Demand.keepAliveDmdEnv.
+
+ALSO: do the same for Ids free in the RHS of any RULES for f.
+
+PS: You may wonder how it can be that f's optimised RHS has somehow
+discarded 'g', but when f is inlined we /don't/ discard g in the same
+way. I think a simple example is
+   g = (a,b)
+   f = \x.  fst g
+   {-# INLINE f #-}
+
+Now f's optimised RHS will be \x.a, but if we change g to (error "..")
+(since it is apparently Absent) and then inline (\x. fst g) we get
+disaster.  But regardless, #18638 was a more complicated version of
+this, that actually happened in practice.
 
 Historical Note [Product demands for function body]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs
index ef22c98315..ec008ab07c 100644
--- a/compiler/GHC/Types/Demand.hs
+++ b/compiler/GHC/Types/Demand.hs
@@ -25,7 +25,7 @@ module GHC.Types.Demand (
         BothDmdArg, mkBothDmdArg, toBothDmdArg,
         nopDmdType, botDmdType, addDemand,
 
-        DmdEnv, emptyDmdEnv,
+        DmdEnv, emptyDmdEnv, keepAliveDmdEnv,
         peelFV, findIdDemand,
 
         Divergence(..), lubDivergence, isDeadEndDiv,
@@ -59,8 +59,9 @@ module GHC.Types.Demand (
 
 import GHC.Prelude
 
-import GHC.Types.Var ( Var )
+import GHC.Types.Var ( Var, Id )
 import GHC.Types.Var.Env
+import GHC.Types.Var.Set
 import GHC.Types.Unique.FM
 import GHC.Types.Basic
 import GHC.Data.Maybe   ( orElse )
@@ -809,10 +810,22 @@ splitFVs is_thunk rhs_fvs
                     :*:
                     addToUFM_Directly sig_fv  uniq (JD { sd = s,    ud = Abs })
 
-data StrictPair a b = !a :*: !b
+keepAliveDmdEnv :: DmdEnv -> IdSet -> DmdEnv
+-- (keepAliveDmdType dt vs) makes sure that the Ids in vs have
+-- /some/ usage in the returned demand types -- they are not Absent
+-- See Note [Absence analysis for stable unfoldings and RULES]
+--     in GHC.Core.Opt.DmdAnal
+keepAliveDmdEnv env vs
+  = nonDetStrictFoldVarSet add env vs
+  where
+    add :: Id -> DmdEnv -> DmdEnv
+    add v env = extendVarEnv_C add_dmd env v topDmd
 
-strictPairToTuple :: StrictPair a b -> (a, b)
-strictPairToTuple (x :*: y) = (x, y)
+    add_dmd :: Demand -> Demand -> Demand
+    -- If the existing usage is Absent, make it used
+    -- Otherwise leave it alone
+    add_dmd dmd _ | isAbsDmd dmd = topDmd
+                  | otherwise    = dmd
 
 splitProdDmd_maybe :: Demand -> Maybe [Demand]
 -- Split a product into its components, iff there is any
@@ -827,6 +840,11 @@ splitProdDmd_maybe (JD { sd = s, ud = u })
       (Lazy,  Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux)
       _ -> Nothing
 
+data StrictPair a b = !a :*: !b
+
+strictPairToTuple :: StrictPair a b -> (a, b)
+strictPairToTuple (x :*: y) = (x, y)
+
 {- *********************************************************************
 *                                                                      *
                TypeShape and demand trimming
@@ -1541,9 +1559,9 @@ There are several wrinkles:
   can be evaluated in a short finite time -- and that rules out nasty
   cases like the one above.  (I'm not quite sure why this was a
   problem in an earlier version of GHC, but it isn't now.)
+-}
 
-
-************************************************************************
+{- *********************************************************************
 *                                                                      *
                      Demand signatures
 *                                                                      *
diff --git a/testsuite/tests/simplCore/should_run/T18638.hs b/testsuite/tests/simplCore/should_run/T18638.hs
new file mode 100644
index 0000000000..daf35a6e55
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T18638.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE ExistentialQuantification, BangPatterns #-}
+{-# OPTIONS_GHC -O #-}
+
+module Main (main) where
+
+import Data.IORef (newIORef, readIORef)
+
+data Step s = Done
+            | Skip !s
+            | Yield !Char !s
+
+data Stream = forall s. Stream (s -> Step s) !s !Int
+
+unstreamList :: Stream -> [Char]
+unstreamList (Stream next s0 _) = unfold s0
+    where unfold !s = case next s of
+                        Done       -> []
+                        Skip s'    -> unfold s'
+                        Yield x s' -> x : unfold s'
+{-# INLINE [0] unstreamList #-}
+
+appendS :: Stream -> Stream -> Stream
+appendS (Stream next s len) _ = Stream next s len
+{-# INLINE [0] appendS #-}
+
+justifyLeftI :: Int -> Int -> Stream
+justifyLeftI k u =
+  let
+       next Nothing = next (Just 0)
+       next (Just n)
+           | n < k       = Yield 'a' (Just (n+1))
+           | otherwise   = Done
+       {-# INLINE next #-}
+
+     in Stream next Nothing (max k u)
+{-# INLINE [0] justifyLeftI #-}
+
+prettyPrintLogStats :: Int -> [String]
+prettyPrintLogStats rawResults = map fromRow columns
+  where
+    columns :: [Int]
+    columns = map (\_ -> 0) [rawResults]
+
+    moduleLen, lineLen :: Int
+    (moduleLen, lineLen) = foldr (\_ (_,_) -> (5, 2)) (0, 0) columns
+
+    fromRow :: Int -> String
+    fromRow x = unstreamList (justifyLeftI moduleLen x `appendS` justifyLeftI lineLen x)
+
+main :: IO ()
+main = do
+    timingsRef <- newIORef 0
+    timings <- readIORef timingsRef
+    putStrLn $ concat $ prettyPrintLogStats timings
diff --git a/testsuite/tests/simplCore/should_run/T18638.stdout b/testsuite/tests/simplCore/should_run/T18638.stdout
new file mode 100644
index 0000000000..ccc3e7b48d
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T18638.stdout
@@ -0,0 +1 @@
+aaaaa
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index efaf5efdde..a04558be89 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -92,3 +92,4 @@ test('T17206', exit_code(1), compile_and_run, [''])
 test('T17151', [], multimod_compile_and_run, ['T17151', ''])
 test('T18012', normal, compile_and_run, [''])
 test('T17744', normal, compile_and_run, [''])
+test('T18638', normal, compile_and_run, [''])