DmdAnal: Reflect the `seq` of strict fields of a DataCon worker (#22475)wip/T22475

See the updated `Note [Data-con worker strictness]`
and the new `Note [Demand transformer for data constructors]`.

Fixes #22475.

10 files changed, 168 insertions, 33 deletions

diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs
index 043cb82574..e3d6331195 100644
--- a/compiler/GHC/Core/DataCon.hs
+++ b/compiler/GHC/Core/DataCon.hs
@@ -901,19 +901,36 @@ instance Outputable EqSpec where
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Notice that we do *not* say the worker Id is strict even if the data
 constructor is declared strict
-     e.g.    data T = MkT !(Int,Int)
-Why?  Because the *wrapper* $WMkT is strict (and its unfolding has case
-expressions that do the evals) but the *worker* MkT itself is not. If we
-pretend it is strict then when we see
-     case x of y -> MkT y
-the simplifier thinks that y is "sure to be evaluated" (because the worker MkT
-is strict) and drops the case.  No, the workerId MkT is not strict.
-
-However, the worker does have StrictnessMarks.  When the simplifier sees a
-pattern
-     case e of MkT x -> ...
-it uses the dataConRepStrictness of MkT to mark x as evaluated; but that's
-fine... dataConRepStrictness comes from the data con not from the worker Id.
+     e.g.    data T = MkT ![Int] Bool
+Even though most often the evals are done by the *wrapper* $WMkT, there are
+situations in which tag inference will re-insert evals around the worker.
+So for all intents and purposes the *worker* MkT is strict, too!
+
+Unfortunately, if we exposed accurate strictness of DataCon workers, we'd
+see the following transformation:
+
+  f xs = case xs of xs' { __DEFAULT -> ... case MkT xs b of x { __DEFAULT -> [x] } } -- DmdAnal: Strict in xs
+  ==> { drop-seq, binder swap on xs' }
+  f xs = case MkT xs b of x { __DEFAULT -> [x] } -- DmdAnal: Still strict in xs
+  ==> { case-to-let }
+  f xs = let x = MkT xs' b in [x] -- DmdAnal: No longer strict in xs!
+
+I.e., we are ironically losing strictness in `xs` by dropping the eval on `xs`
+and then doing case-to-let. The issue is that `exprIsHNF` currently says that
+every DataCon worker app is a value. The implicit assumption is that surrounding
+evals will have evaluated strict fields like `xs` before! But now that we had
+just dropped the eval on `xs`, that assumption is no longer valid.
+
+Long story short: By keeping the demand signature lazy, the Simplifier will not
+drop the eval on `xs` and using `exprIsHNF` to decide case-to-let and others
+remains sound.
+
+Similarly, during demand analysis in dmdTransformDataConSig, we bump up the
+field demand with `C_01`, *not* `C_11`, because the latter exposes too much
+strictness that will drop the eval on `xs` above.
+
+This issue is discussed at length in
+"Failed idea: no wrappers for strict data constructors" in #21497 and #22475.
 
 Note [Bangs on data constructor arguments]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs
index b12478cbab..fbbcf1c2ad 100644
--- a/compiler/GHC/Core/Opt/Arity.hs
+++ b/compiler/GHC/Core/Opt/Arity.hs
@@ -2677,7 +2677,7 @@ tryEtaReduce rec_ids bndrs body eval_sd
       -- ... and that the function can be eta reduced to arity 0
       -- without violating invariants of Core and GHC
       && canEtaReduceToArity fun 0 0              -- criteria (L), (J), (W), (B)
-    all_calls_with_arity n = isStrict (peelManyCalls n eval_sd)
+    all_calls_with_arity n = isStrict (fst $ peelManyCalls n eval_sd)
        -- See Note [Eta reduction based on evaluation context]
 
     ---------------
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index a14964c12e..74316e1e1b 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/compiler/GHC/Core/Opt/DmdAnal.hs
@@ -982,9 +982,9 @@ dmdTransform :: AnalEnv   -- ^ The analysis environment
 -- See Note [What are demand signatures?] in "GHC.Types.Demand"
 dmdTransform env var sd
   -- Data constructors
-  | isDataConWorkId var
-  = -- pprTraceWith "dmdTransform:DataCon" (\ty -> ppr var $$ ppr sd $$ ppr ty) $
-    dmdTransformDataConSig (idArity var) sd
+  | Just con <- isDataConWorkId_maybe var
+  = -- pprTraceWith "dmdTransform:DataCon" (\ty -> ppr con $$ ppr sd $$ ppr ty) $
+    dmdTransformDataConSig (dataConRepStrictness con) sd
   -- See Note [DmdAnal for DataCon wrappers]
   | isDataConWrapId var, let rhs = uf_tmpl (realIdUnfolding var)
   , WithDmdType dmd_ty _rhs' <- dmdAnal env sd rhs
diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs
index 6b46b5125c..dbb9504813 100644
--- a/compiler/GHC/Stg/Lift/Analysis.hs
+++ b/compiler/GHC/Stg/Lift/Analysis.hs
@@ -326,7 +326,7 @@ tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body)
 rhsCard :: Id -> Card
 rhsCard bndr
   | is_thunk  = oneifyCard n
-  | otherwise = n `multCard` peelManyCalls (idArity bndr) cd
+  | otherwise = n `multCard` (fst $ peelManyCalls (idArity bndr) cd)
   where
     is_thunk = idArity bndr == 0
     -- Let's pray idDemandInfo is still OK after unarise...
diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs
index 02fa910e94..9890b55dee 100644
--- a/compiler/GHC/Types/Demand.hs
+++ b/compiler/GHC/Types/Demand.hs
@@ -94,7 +94,7 @@ import GHC.Data.Maybe   ( orElse )
 
 import GHC.Core.Type    ( Type )
 import GHC.Core.TyCon   ( isNewTyCon, isClassTyCon )
-import GHC.Core.DataCon ( splitDataProductType_maybe )
+import GHC.Core.DataCon ( splitDataProductType_maybe, StrictnessMark, isMarkedStrict )
 import GHC.Core.Multiplicity    ( scaledThing )
 
 import GHC.Utils.Binary
@@ -1032,10 +1032,13 @@ peelCallDmd sd = viewCall sd `orElse` (topCard, topSubDmd)
 -- whether it was unsaturated in the form of a 'Card'inality, denoting
 -- how many times the lambda body was entered.
 -- See Note [Demands from unsaturated function calls].
-peelManyCalls :: Int -> SubDemand -> Card
-peelManyCalls 0 _                          = C_11
-peelManyCalls n (viewCall -> Just (m, sd)) = m `multCard` peelManyCalls (n-1) sd
-peelManyCalls _ _                          = C_0N
+peelManyCalls :: Arity -> SubDemand -> (Card, SubDemand)
+peelManyCalls k sd = go k C_11 sd
+  where
+    go 0 !n !sd                        = (n, sd)
+    go k !n (viewCall -> Just (m, sd)) = go (k-1) (n `multCard` m) sd
+    go _ _  _                          = (topCard, topSubDmd)
+{-# INLINE peelManyCalls #-} -- so that the pair cancels away in a `fst _` context
 
 -- | Extract the 'SubDemand' of a 'Demand'.
 -- PRECONDITION: The SubDemand must be used in a context where the expression
@@ -1085,7 +1088,7 @@ argOneShots (_ :* sd) = go sd
 saturatedByOneShots :: Int -> Demand -> Bool
 saturatedByOneShots _ AbsDmd    = True
 saturatedByOneShots _ BotDmd    = True
-saturatedByOneShots n (_ :* sd) = isUsedOnce (peelManyCalls n sd)
+saturatedByOneShots n (_ :* sd) = isUsedOnce $ fst $ peelManyCalls n sd
 
 {- Note [Strict demands]
 ~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1374,6 +1377,46 @@ Note [Demand transformer for a dictionary selector] explains. Annoyingly,
 the boxity info has to be stored in the *sub-demand* `sd`! There's no demand
 to store the boxity in. So we bit the bullet and now we store Boxity in
 'SubDemand', both in 'Prod' *and* 'Poly'. See also Note [Boxity in Poly].
+
+Note [Demand transformer for data constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the expression (x,y) with sub-demand P(SL,A).  What is the demand on
+x,y?  Obviously `x` is used strictly, and `y` not at all. So we want to
+decompose a product demand, and feed its components demands into the
+arguments.  That is the job of dmdTransformDataConSig.  More precisely,
+
+ * it gets the demand on the data constructor itself;
+   in the above example that is C(1,C(1,P(SL,A)))
+ * it returns the demands on the arguments;
+   in the above example that is [SL, A]
+
+Nasty wrinkle. Consider this code (#22475 has more realistic examples but
+assume this is what the demand analyser sees)
+
+   data T = MkT !Int Bool
+   get :: T -> Bool
+   get (MkT _ b) = b
+
+   foo = let v::Int = I# 7
+             t::T   = MkT v True
+         in get t
+
+Now `v` is unused by `get`, /but/ we can't give `v` an Absent demand,
+else we'll drop the binding and replace it with an error thunk.
+Then the code generator (more specifically GHC.Stg.InferTags.Rewrite)
+will add an extra eval of MkT's argument to give
+   foo = let v::Int = error "absent"
+             t::T   = case v of v' -> MkT v' True
+         in get t
+
+Boo!  Because of this extra eval (added in STG-land), the truth is that `MkT`
+may (or may not) evaluate its arguments (as established in #21497). Hence the
+use of `bump` in dmdTransformDataConSig, which adds in a `C_01` eval. The
+`C_01` says "may or may not evaluate" which is absolutely faithful to what
+InferTags.Rewrite does.
+
+In particular it is very important /not/ to make that a `C_11` eval,
+see Note [Data-con worker strictness].
 -}
 
 {- *********************************************************************
@@ -2266,20 +2309,24 @@ type DmdTransformer = SubDemand -> DmdType
 -- return how the function evaluates its free variables and arguments.
 dmdTransformSig :: DmdSig -> DmdTransformer
 dmdTransformSig (DmdSig dmd_ty@(DmdType _ arg_ds _)) sd
-  = multDmdType (peelManyCalls (length arg_ds) sd) dmd_ty
+  = multDmdType (fst $ peelManyCalls (length arg_ds) sd) dmd_ty
     -- see Note [Demands from unsaturated function calls]
     -- and Note [What are demand signatures?]
 
 -- | A special 'DmdTransformer' for data constructors that feeds product
 -- demands into the constructor arguments.
-dmdTransformDataConSig :: Arity -> DmdTransformer
-dmdTransformDataConSig arity sd = case go arity sd of
-  Just dmds -> DmdType emptyDmdEnv dmds topDiv
-  Nothing   -> nopDmdType -- Not saturated
+dmdTransformDataConSig :: [StrictnessMark] -> DmdTransformer
+-- See Note [Demand transformer for data constructors]
+dmdTransformDataConSig str_marks sd = case viewProd arity body_sd of
+  Just (_, dmds) -> mk_body_ty n dmds
+  Nothing        -> nopDmdType
   where
-    go 0 sd             = snd <$> viewProd arity sd
-    go n (Call C_11 sd) = go (n-1) sd  -- strict calls only!
-    go _ _              = Nothing
+    arity = length str_marks
+    (n, body_sd) = peelManyCalls arity sd
+    mk_body_ty n dmds = DmdType emptyDmdEnv (zipWith (bump n) str_marks dmds) topDiv
+    bump n str dmd | isMarkedStrict str = multDmd n (plusDmd str_field_dmd dmd)
+                   | otherwise          = multDmd n dmd
+    str_field_dmd = C_01 :* seqSubDmd -- Why not C_11? See Note [Data-con worker strictness]
 
 -- | A special 'DmdTransformer' for dictionary selectors that feeds the demand
 -- on the result into the indicated dictionary component (if saturated).
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index 41e37b7f69..4baa335db1 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -700,7 +700,7 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con
                              -- applications are treated as values
                          `setInlinePragInfo`    wrap_prag
                          `setUnfoldingInfo`     wrap_unf
-                         `setDmdSigInfo`    wrap_sig
+                         `setDmdSigInfo`        wrap_sig
                              -- We need to get the CAF info right here because GHC.Iface.Tidy
                              -- does not tidy the IdInfo of implicit bindings (like the wrapper)
                              -- so it not make sure that the CAF info is sane
diff --git a/testsuite/tests/stranal/should_run/T22475.hs b/testsuite/tests/stranal/should_run/T22475.hs
new file mode 100644
index 0000000000..3c66450475
--- /dev/null
+++ b/testsuite/tests/stranal/should_run/T22475.hs
@@ -0,0 +1,47 @@
+{-# OPTIONS_GHC -O -fforce-recomp #-}
+{-# OPTIONS_GHC -fmax-worker-args=0 #-}
+{-# LANGUAGE StrictData #-}
+
+import Control.Monad
+import Control.Exception
+import GHC.Conc
+import System.Timeout
+
+twiceIO :: (Int -> IO ()) -> IO ()
+twiceIO f = f 0 >> f 1
+{-# NOINLINE twiceIO #-}
+
+data Config
+  = Cfg
+  { a :: Integer
+  , b :: Integer
+  , c :: Integer
+  , params :: (Maybe Int)
+  , e :: Integer
+  , f :: Integer
+  , g :: Integer
+  , h :: Integer
+  , i :: Integer
+  , j :: Integer
+  , k :: Integer
+  }
+
+rnf :: Config -> ()
+rnf (Cfg a b c _ e f g h i j k) = a + b + c + e + f + g + h + i + j + k `seq` ()
+
+handshakeServer' :: Config -> Int -> IO ()
+handshakeServer' cfg 0 = rnf cfg `seq` return ()
+handshakeServer' _   _ = return ()
+{-# NOINLINE handshakeServer' #-}
+
+run :: Config -> Int -> IO ()
+run conf n = do
+  tv <- rnf conf `seq` params conf `seq` newTVarIO 0
+  forever $ do
+    acc <- rnf conf `seq` readTVarIO tv
+    let conf' = conf{params=Just acc}
+    forkIO $ twiceIO (\eta -> handshakeServer' conf' (eta+acc))
+{-# NOINLINE run #-}
+
+-- The crash should happen instantly, within the first 10ms. 100ms is a safe bet
+main = timeout 100 $ run (Cfg 0 1 2 (Just 3) 4 5 6 7 8 9 10) 13
diff --git a/testsuite/tests/stranal/should_run/T22475b.hs b/testsuite/tests/stranal/should_run/T22475b.hs
new file mode 100644
index 0000000000..965d7e0fc8
--- /dev/null
+++ b/testsuite/tests/stranal/should_run/T22475b.hs
@@ -0,0 +1,21 @@
+{-# OPTIONS_GHC -O -fforce-recomp #-}
+{-# OPTIONS_GHC -fmax-worker-args=0 #-}
+
+data Config
+  = Cfg
+  { a      :: Integer
+  , params :: !(Maybe Int)
+  }
+
+use :: Bool -> Config -> Int
+use True cfg = a cfg `seq` 42
+use _    _   = 0
+{-# NOINLINE use #-}
+
+run :: Config -> Int -> Int
+run conf n =
+  let !conf' = conf{params=Just n}
+  in use True conf' + use False conf'
+{-# NOINLINE run #-}
+
+main = print $ run (Cfg 0 (Just 1)) 13
diff --git a/testsuite/tests/stranal/should_run/T22475b.stdout b/testsuite/tests/stranal/should_run/T22475b.stdout
new file mode 100644
index 0000000000..d81cc0710e
--- /dev/null
+++ b/testsuite/tests/stranal/should_run/T22475b.stdout
@@ -0,0 +1 @@
+42
diff --git a/testsuite/tests/stranal/should_run/all.T b/testsuite/tests/stranal/should_run/all.T
index 5f7749b50e..a2b8e4cfc5 100644
--- a/testsuite/tests/stranal/should_run/all.T
+++ b/testsuite/tests/stranal/should_run/all.T
@@ -28,3 +28,5 @@ test('T14285', normal, multimod_compile_and_run, ['T14285', ''])
 test('T17676', normal, compile_and_run, [''])
 test('T19053', normal, compile_and_run, [''])
 test('T21717b', normal, compile_and_run, [''])
+test('T22475', normal, compile_and_run, [''])
+test('T22475b', normal, compile_and_run, [''])