Make DataCon workers strict in strict fields (#20749)wip/T20749

This patch tweaks `exprIsConApp_maybe`, `exprIsHNF` and friends, and Demand
Analysis so that they exploit and maintain strictness of DataCon workers. See
`Note [Strict fields in Core]` for details.

Very little needed to change, and it puts field seq insertion done by Tag
Inference into a new perspective: That of *implementing* strict field semantics.
Before Tag Inference, DataCon workers are strict. Afterwards they are
effectively lazy and field seqs happen around use sites. History has shown
that there is no other way to guarantee taggedness and thus the STG Strict Field
Invariant.

Knock-on changes:

  * `exprIsHNF` previously used `exprOkForSpeculation` on unlifted arguments
    instead of recursing into `exprIsHNF`. That regressed the termination
    analysis in CPR analysis (which simply calls out to `exprIsHNF`), so I made
    it call `exprOkForSpeculation`, too.

  * There's a small regression in Demand Analysis, visible in the changed test
    output of T16859: Previously, a field seq on a variable would give that
    variable a "used exactly once" demand, now it's "used at least once",
    because `dmdTransformDataConSig` accounts for future uses of the field
    that actually all go through the case binder (and hence won't re-enter the
    potential thunk). The difference should hardly be observable.

  * The Simplifier's fast path for data constructors only applies to lazy
    data constructors now. I observed regressions involving Data.Binary.Put's
    `Pair` data type.

  * Unfortunately, T21392 does no longer reproduce after this patch, so I marked
    it as "not broken" in order to track whether we regress again in the future.

Fixes #20749, the satisfying conclusion of an annoying saga (cf. the ideas
in #21497 and #22475).

1 files changed, 35 insertions, 7 deletions

diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs
index 609d007a5a..77ddde68a2 100644
--- a/compiler/GHC/Core/SimpleOpt.hs
+++ b/compiler/GHC/Core/SimpleOpt.hs
@@ -1219,11 +1219,8 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
        --       simplifier produces rhs[exp/a], changing semantics if exp is not ok-for-spec
        -- Good: returning (Mk#, [x]) with a float of  case exp of x { DEFAULT -> [] }
        --       simplifier produces case exp of a { DEFAULT -> exp[x/a] }
-       = let arg' = subst_expr subst arg
-             bndr = uniqAway (subst_in_scope subst) (mkWildValBinder ManyTy arg_type)
-             float = FloatCase arg' bndr DEFAULT []
-             subst' = subst_extend_in_scope subst bndr
-         in go subst' (float:floats) fun (CC (Var bndr : args) co)
+       , (subst', float, bndr) <- case_bind subst arg arg_type
+       = go subst' (float:floats) fun (CC (Var bndr : args) co)
        | otherwise
        = go subst floats fun (CC (subst_expr subst arg : args) co)
 
@@ -1262,8 +1259,9 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
 
         | Just con <- isDataConWorkId_maybe fun
         , count isValArg args == idArity fun
-        = succeedWith in_scope floats $
-          pushCoDataCon con args co
+        , (in_scope', seq_floats, args') <- mkFieldSeqFloats in_scope con args
+        = succeedWith in_scope' (seq_floats ++ floats) $
+          pushCoDataCon con args' co
 
         -- Look through data constructor wrappers: they inline late (See Note
         -- [Activation for data constructor wrappers]) but we want to do
@@ -1349,6 +1347,36 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
     extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e)
     extend (Right s)       v e = Right (extendSubst s v e)
 
+    case_bind :: Either InScopeSet Subst -> CoreExpr -> Type -> (Either InScopeSet Subst, FloatBind, Id)
+    case_bind subst expr expr_ty = (subst', float, bndr)
+      where
+        bndr   = setCaseBndrEvald MarkedStrict $
+                 uniqAway (subst_in_scope subst) $
+                 mkWildValBinder ManyTy expr_ty
+        subst' = subst_extend_in_scope subst bndr
+        expr'  = subst_expr subst expr
+        float  = FloatCase expr' bndr DEFAULT []
+
+    mkFieldSeqFloats :: InScopeSet -> DataCon -> [CoreExpr] -> (InScopeSet, [FloatBind], [CoreExpr])
+    mkFieldSeqFloats in_scope dc args
+      | Nothing <- dataConRepStrictness_maybe dc
+      = (in_scope, [], args)
+      | otherwise
+      = (in_scope', floats', ty_args ++ val_args')
+      where
+        (ty_args, val_args) = splitAtList (dataConUnivAndExTyCoVars dc) args
+        (in_scope', floats', val_args') = foldr do_one (in_scope, [], []) $ zipEqual "mkFieldSeqFloats" str_marks val_args
+        str_marks = dataConRepStrictness dc
+        do_one (str, arg) (in_scope,floats,args)
+          | NotMarkedStrict <- str   = (in_scope, floats, arg:args)
+          | Var v <- arg, is_evald v = (in_scope, floats, arg:args)
+          | otherwise                = (in_scope', float:floats, Var bndr:args)
+          where
+            is_evald v = isId v && isEvaldUnfolding (idUnfolding v)
+            (in_scope', float, bndr) =
+               case case_bind (Left in_scope) arg (exprType arg) of
+                 (Left in_scope', float, bndr) -> (in_scope', float, bndr)
+                 (right, _, _) -> pprPanic "case_bind did not preserve Left" (ppr in_scope $$ ppr arg $$ ppr right)
 
 -- See Note [exprIsConApp_maybe on literal strings]
 dealWithStringLiteral :: Var -> BS.ByteString -> Coercion