DmdAnal: Look through unfoldings of DataCon wrappers (#22241)wip/T22241

Previously, the demand signature we computed upfront for a DataCon wrapper

lacked boxity information and was much less precise than the demand transformer

for the DataCon worker.

In this patch we adopt the solution to look through unfoldings of DataCon

wrappers during Demand Analysis, but still attach a demand signature for other

passes such as the Simplifier.

See `Note [DmdAnal for DataCon wrappers]` for more details.

Fixes #22241.

6 files changed, 111 insertions, 7 deletions

diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs
index e13be005fb..87d9eb2ec7 100644
--- a/compiler/GHC/Core/Opt/CprAnal.hs
+++ b/compiler/GHC/Core/Opt/CprAnal.hs
@@ -553,13 +553,16 @@ analysing their unfolding. A few reasons for the change:
      *workers*, because their transformers need to adapt to CPR for their
      arguments in 'cprTransformDataConWork' to enable Note [Nested CPR].
      Better keep it all in this module! The alternative would be that
-     'GHC.Types.Id.Make' depends on DmdAnal.
+     'GHC.Types.Id.Make' depends on CprAnal.
   3. In the future, Nested CPR could take a better account of incoming args
      in cprAnalApp and do some beta-reduction on the fly, like !1866 did. If
      any of those args had the CPR property, then we'd even get Nested CPR for
      DataCon wrapper calls, for free. Not so if we simply give the wrapper a
      single CPR sig in 'GHC.Types.Id.Make.mkDataConRep'!
 
+DmdAnal also looks through the wrapper's unfolding:
+See Note [DmdAnal for DataCon wrappers].
+
 Note [Trimming to mAX_CPR_SIZE]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We do not treat very big tuples as CPR-ish:
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index 1263792d05..4f5d23c05c 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/compiler/GHC/Core/Opt/DmdAnal.hs
@@ -985,6 +985,10 @@ dmdTransform env var sd
   | isDataConWorkId var
   = -- pprTraceWith "dmdTransform:DataCon" (\ty -> ppr var $$ ppr sd $$ ppr ty) $
     dmdTransformDataConSig (idArity var) sd
+  -- See Note [DmdAnal for DataCon wrappers]
+  | isDataConWrapId var, let rhs = uf_tmpl (realIdUnfolding var)
+  , WithDmdType dmd_ty _rhs' <- dmdAnal env sd rhs
+  = dmd_ty
   -- Dictionary component selectors
   -- Used to be controlled by a flag.
   -- See #18429 for some perf measurements.
@@ -1388,6 +1392,45 @@ Now f's optimised RHS will be \x.a, but if we change g to (error "..")
 disaster.  But regardless, #18638 was a more complicated version of
 this, that actually happened in practice.
 
+Note [DmdAnal for DataCon wrappers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We give DataCon wrappers a (necessarily flat) demand signature in
+`GHC.Types.Id.Make.mkDataConRep`, so that passes such as the Simplifier can
+exploit it via the call to `GHC.Core.Opt.Simplify.Utils.isStrictArgInfo` in
+`GHC.Core.Opt.Simplify.Iteration.rebuildCall`. But during DmdAnal, we *ignore*
+the demand signature of a DataCon wrapper, and instead analyse its unfolding at
+every call site.
+
+The reason is that DataCon *worker*s have very precise demand transformers,
+computed by `dmdTransformDataConSig`. It would be awkward if DataCon *wrappers*
+would behave much less precisely during DmdAnal. Example:
+
+   data T1 = MkT1 { get_x1 :: Int,  get_y1 :: Int }
+   data T2 = MkT2 { get_x2 :: !Int, get_y2 :: Int }
+   f1 x y = get_x1 (MkT1 x y)
+   f2 x y = get_x2 (MkT2 x y)
+
+Here `MkT1` has no wrapper. `get_x1` puts a demand `!P(1!L,A)` on its argument,
+and `dmdTransformDataConSig` will transform that demand to an absent demand on
+`y` in `f1` and an unboxing demand on `x`.
+But `MkT2` has a wrapper (to evaluate the first field). If demand analysis deals
+with `MkT2` only through its demand signature, demand signatures can't transform
+an incoming demand `P(1!L,A)` in a useful way, so we won't get an absent demand
+on `y` in `f2` or see that `x` can be unboxed. That's a serious loss.
+
+The example above will not actually occur, because $WMkT2 would be inlined.
+Nevertheless, we can get interesting sub-demands on DataCon wrapper
+applications in boring contexts; see T22241.
+
+You might worry about the efficiency cost of demand-analysing datacon wrappers
+at every call site. But in fact they are inlined /anyway/ in the Final phase,
+which happens before DmdAnal, so few wrappers remain. And analysing the
+unfoldings for the remaining calls (which are those in a boring context) will be
+exactly as (in)efficent as if we'd inlined those calls. It turns out to be not
+measurable in practice.
+
+See also Note [CPR for DataCon wrappers] in `GHC.Core.Opt.CprAnal`.
+
 Note [Boxity for bottoming functions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider (A)
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index 7b0e15df91..b38cde14a1 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -477,9 +477,9 @@ mkDictSelId name clas
                -- See Note [Type classes and linear types]
 
     base_info = noCafIdInfo
-                `setArityInfo`          1
-                `setDmdSigInfo`     strict_sig
-                `setCprSigInfo`            topCprSig
+                `setArityInfo`  1
+                `setDmdSigInfo` strict_sig
+                `setCprSigInfo` topCprSig
 
     info | new_tycon
          = base_info `setInlinePragInfo` alwaysInlinePragma
@@ -697,6 +697,8 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con
                              -- does not tidy the IdInfo of implicit bindings (like the wrapper)
                              -- so it not make sure that the CAF info is sane
 
+             -- The signature is purely for passes like the Simplifier, not for
+             -- DmdAnal itself; see Note [DmdAnal for DataCon wrappers].
              wrap_sig = mkClosedDmdSig wrap_arg_dmds topDiv
 
              wrap_arg_dmds =
@@ -1321,9 +1323,9 @@ mkFCallId uniq fcall ty
     name = mkFCallName uniq occ_str
 
     info = noCafIdInfo
-           `setArityInfo`          arity
-           `setDmdSigInfo`     strict_sig
-           `setCprSigInfo`            topCprSig
+           `setArityInfo`  arity
+           `setDmdSigInfo` strict_sig
+           `setCprSigInfo` topCprSig
 
     (bndrs, _) = tcSplitPiTys ty
     arity      = count isAnonTyCoBinder bndrs
diff --git a/testsuite/tests/stranal/sigs/T22241.hs b/testsuite/tests/stranal/sigs/T22241.hs
new file mode 100644
index 0000000000..21bf7b1d6b
--- /dev/null
+++ b/testsuite/tests/stranal/sigs/T22241.hs
@@ -0,0 +1,31 @@
+module T22241 where
+
+data D = D { unD :: !Int }
+
+-- We should unbox y here, which only happens if DmdAnal sees that $WD will
+-- unbox it.
+f :: Bool -> Int -> D
+f x y = D (go x)
+  where
+    go False = y
+    go True  = go False
+{-# NOINLINE f #-}
+
+
+
+data T a = T Int !a
+get (T _ x) = x
+
+-- Here, the goal is to discard `unD (f True z)` and thus `z` as absent by
+-- looking through $WT in `j` *during the first pass of DmdAnal*!
+g :: Bool -> Int -> Int -> Bool
+g x y z | even y    = get (fst t)
+        | y > 13    = not (get (fst t))
+        | otherwise = False
+  where
+    t | x         = j (unD (f True z))
+      | otherwise = j (unD (f False z))
+      where
+        j a = (T a x, True)
+        {-# NOINLINE j #-}
+{-# NOINLINE g #-}
diff --git a/testsuite/tests/stranal/sigs/T22241.stderr b/testsuite/tests/stranal/sigs/T22241.stderr
new file mode 100644
index 0000000000..284fe2cf76
--- /dev/null
+++ b/testsuite/tests/stranal/sigs/T22241.stderr
@@ -0,0 +1,24 @@
+
+==================== Strictness signatures ====================
+T22241.f: <1L><S!P(L)>
+T22241.g: <L><1!P(L)><A>
+T22241.get: <1!P(A,1L)>
+T22241.unD: <1!P(L)>
+
+
+
+==================== Cpr signatures ====================
+T22241.f: 1
+T22241.g:
+T22241.get:
+T22241.unD: 1
+
+
+
+==================== Strictness signatures ====================
+T22241.f: <1L><1!P(SL)>
+T22241.g: <ML><1!P(L)><A>
+T22241.get: <1!P(A,1L)>
+T22241.unD: <1!P(L)>
+
+
diff --git a/testsuite/tests/stranal/sigs/all.T b/testsuite/tests/stranal/sigs/all.T
index 73ecf7be57..01ea48cfe8 100644
--- a/testsuite/tests/stranal/sigs/all.T
+++ b/testsuite/tests/stranal/sigs/all.T
@@ -37,3 +37,4 @@ test('T21717', normal, compile, [''])
 test('T21754', normal, compile, [''])
 test('T21888', normal, compile, [''])
 test('T21888a', normal, compile, [''])
+test('T22241', normal, compile, [''])