Mark DataCon wrappers CONLIKE

Now that DataCon wrappers don’t inline until phase 0 (see commit
b78cc64e923716ac0512c299f42d4d0012306c05), it’s important that
case-of-known-constructor and RULE matching be able to see saturated
applications of DataCon wrappers in unfoldings. Making them conlike is a
natural way to do it, since they are, in fact, precisely the sort of
thing the CONLIKE pragma exists to solve.

Fixes #18012.

This also bumps the version of the parsec submodule to incorporate a
patch that avoids a metric increase on the haddock perf tests. The
increase was not really a flaw in this patch, as parsec was implicitly
relying on inlining heuristics. The patch to parsec just adds some
INLINABLE pragmas, and we get a nice performance bump out of it (well
beyond the performance we lost from this patch).

Metric Decrease:
    T12234
    WWRec
    haddock.Cabal
    haddock.base
    haddock.compiler

12 files changed, 162 insertions, 19 deletions

diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs
index 0728ea11c8..7545209b77 100644
--- a/compiler/GHC/Core/SimpleOpt.hs
+++ b/compiler/GHC/Core/SimpleOpt.hs
@@ -889,6 +889,10 @@ And now we have a known-constructor MkT that we can return.
 Notice that both (2) and (3) require exprIsConApp_maybe to gather and return
 a bunch of floats, both let and case bindings.
 
+Note that this strategy introduces some subtle scenarios where a data-con
+wrapper can be replaced by a data-con worker earlier than we’d like, see
+Note [exprIsConApp_maybe for data-con wrappers: tricky corner].
+
 Note [beta-reduction in exprIsConApp_maybe]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The unfolding a definition (_e.g._ a let-bound variable or a datacon wrapper) is
@@ -949,6 +953,60 @@ exprIsConApp_maybe does not return Just) then nothing happens, and nothing
 will happen the next time either.
 
 See test T16254, which checks the behavior of newtypes.
+
+Note [exprIsConApp_maybe for data-con wrappers: tricky corner]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generally speaking
+
+  * exprIsConApp_maybe honours the inline phase; that is, it does not look
+    inside the unfolding for an Id unless its unfolding is active in this phase.
+    That phase-sensitivity is expressed in the InScopeEnv (specifically, the
+    IdUnfoldingFun component of the InScopeEnv) passed to exprIsConApp_maybe.
+
+  * Data-constructor wrappers are active only in phase 0 (the last phase);
+    see Note [Activation for data constructor wrappers] in GHC.Types.Id.Make.
+
+On the face of it that means that exprIsConApp_maybe won't look inside data
+constructor wrappers until phase 0. But that seems pretty Bad. So we cheat.
+For data con wrappers we unconditionally look inside its unfolding, regardless
+of phase, so that we get case-of-known-constructor to fire in every phase.
+
+Perhaps unsurprisingly, this cheating can backfire. An example:
+
+    data T = C !A B
+    foo p q = let x = C e1 e2 in seq x $ f x
+    {-# RULE "wurble" f (C a b) = b #-}
+
+In Core, the RHS of foo is
+
+    let x = $WC e1 e2 in case x of y { C _ _ -> f x }
+
+and after doing a binder swap and inlining x, we have:
+
+    case $WC e1 e2 of y { C _ _ -> f y }
+
+Case-of-known-constructor fires, but now we have to reconstruct a binding for
+`y` (which was dead before the binder swap) on the RHS of the case alternative.
+Naturally, we’ll use the worker:
+
+    case e1 of a { DEFAULT -> let y = C a e2 in f y }
+
+and after inlining `y`, we have:
+
+    case e1 of a { DEFAULT -> f (C a e2) }
+
+Now we might hope the "wurble" rule would fire, but alas, it will not: we have
+replaced $WC with C, but the (desugared) rule matches on $WC! We weren’t
+supposed to inline $WC yet for precisely that reason (see Note [Activation for
+data constructor wrappers]), but our cheating in exprIsConApp_maybe came back to
+bite us.
+
+This is rather unfortunate, especially since this can happen inside stable
+unfoldings as well as ordinary code (which really happened, see !3041). But
+there is no obvious solution except to delay case-of-known-constructor on
+data-con wrappers, and that cure would be worse than the disease.
+
+This Note exists solely to document the problem.
 -}
 
 data ConCont = CC [CoreExpr] Coercion
@@ -1033,7 +1091,8 @@ exprIsConApp_maybe (in_scope, id_unf) expr
 
         -- Look through data constructor wrappers: they inline late (See Note
         -- [Activation for data constructor wrappers]) but we want to do
-        -- case-of-known-constructor optimisation eagerly.
+        -- case-of-known-constructor optimisation eagerly (see Note
+        -- [exprIsConApp_maybe on data constructors with wrappers]).
         | isDataConWrapId fun
         , let rhs = uf_tmpl (realIdUnfolding fun)
         = go (Left in_scope) floats rhs cont
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs
index a0704ef03a..d954374eef 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/compiler/GHC/Core/Utils.hs
@@ -91,7 +91,7 @@ import GHC.Builtin.Types.Prim
 import FastString
 import Maybes
 import ListSetOps       ( minusList )
-import GHC.Types.Basic     ( Arity, isConLike )
+import GHC.Types.Basic     ( Arity )
 import Util
 import Pair
 import Data.ByteString     ( ByteString )
@@ -1387,15 +1387,14 @@ isExpandableApp fn n_val_args
   | isWorkFreeApp fn n_val_args = True
   | otherwise
   = case idDetails fn of
-      DataConWorkId {} -> True  -- Actually handled by isWorkFreeApp
-      RecSelId {}      -> n_val_args == 1  -- See Note [Record selection]
-      ClassOpId {}     -> n_val_args == 1
-      PrimOpId {}      -> False
-      _ | isBottomingId fn               -> False
+      RecSelId {}  -> n_val_args == 1  -- See Note [Record selection]
+      ClassOpId {} -> n_val_args == 1
+      PrimOpId {}  -> False
+      _ | isBottomingId fn   -> False
           -- See Note [isExpandableApp: bottoming functions]
-        | isConLike (idRuleMatchInfo fn) -> True
-        | all_args_are_preds             -> True
-        | otherwise                      -> False
+        | isConLikeId fn     -> True
+        | all_args_are_preds -> True
+        | otherwise          -> False
 
   where
      -- See if all the arguments are PredTys (implicit params or classes)
diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs
index fab72d23de..713f1c6258 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/compiler/GHC/Types/Id.hs
@@ -768,7 +768,7 @@ idRuleMatchInfo :: Id -> RuleMatchInfo
 idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id)
 
 isConLikeId :: Id -> Bool
-isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id)
+isConLikeId id = isConLike (idRuleMatchInfo id)
 
 {-
         ---------------------------------
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index ce5012458a..d9d137a13b 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -510,19 +510,21 @@ mkDataConWorkId wkr_name data_con
     alg_wkr_info = noCafIdInfo
                    `setArityInfo`          wkr_arity
                    `setCprInfo`            mkCprSig wkr_arity (dataConCPR data_con)
+                   `setInlinePragInfo`     wkr_inline_prag
                    `setUnfoldingInfo`      evaldUnfolding  -- Record that it's evaluated,
                                                            -- even if arity = 0
                    `setLevityInfoWithType` wkr_ty
                      -- NB: unboxed tuples have workers, so we can't use
                      -- setNeverLevPoly
 
+    wkr_inline_prag = defaultInlinePragma { inl_rule = ConLike }
     wkr_arity = dataConRepArity data_con
     ----------- Workers for newtypes --------------
     univ_tvs = dataConUnivTyVars data_con
     arg_tys  = dataConRepArgTys  data_con  -- Should be same as dataConOrigArgTys
     nt_work_info = noCafIdInfo          -- The NoCaf-ness is set by noCafIdInfo
                   `setArityInfo` 1      -- Arity 1
-                  `setInlinePragInfo`     alwaysInlinePragma
+                  `setInlinePragInfo`     dataConWrapperInlinePragma
                   `setUnfoldingInfo`      newtype_unf
                   `setLevityInfoWithType` wkr_ty
     id_arg1      = mkTemplateLocal 1 (head arg_tys)
@@ -652,8 +654,8 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
              mk_dmd str | isBanged str = evalDmd
                         | otherwise    = topDmd
 
-             wrap_prag = alwaysInlinePragma `setInlinePragmaActivation`
-                         activeDuringFinal
+             wrap_prag = dataConWrapperInlinePragma
+                         `setInlinePragmaActivation` activeDuringFinal
                          -- See Note [Activation for data constructor wrappers]
 
              -- The wrapper will usually be inlined (see wrap_unf), so its
@@ -763,6 +765,12 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
            ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)
            ; return (unbox_fn expr) }
 
+
+dataConWrapperInlinePragma :: InlinePragma
+-- See Note [DataCon wrappers are conlike]
+dataConWrapperInlinePragma = alwaysInlinePragma { inl_rule = ConLike
+                                                , inl_inline = Inline }
+
 {- Note [Activation for data constructor wrappers]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The Activation on a data constructor wrapper allows it to inline only in Phase
@@ -784,6 +792,37 @@ the order of type argument could make previously working RULEs fail.
 
 See also https://gitlab.haskell.org/ghc/ghc/issues/15840 .
 
+Note [DataCon wrappers are conlike]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+DataCon workers are clearly ConLike --- they are the “Con” in
+“ConLike”, after all --- but what about DataCon wrappers? Should they
+be marked ConLike, too?
+
+Yes, absolutely! As described in Note [CONLIKE pragma] in
+GHC.Types.Basic, isConLike influences GHC.Core.Utils.exprIsExpandable,
+which is used by both RULE matching and the case-of-known-constructor
+optimization. It’s crucial that both of those things can see
+applications of DataCon wrappers:
+
+  * User-defined RULEs match on wrappers, not workers, so we might
+    need to look through an unfolding built from a DataCon wrapper to
+    determine if a RULE matches.
+
+  * Likewise, if we have something like
+        let x = $WC a b in ... case x of { C y z -> e } ...
+    we still want to apply case-of-known-constructor.
+
+Therefore, it’s important that we consider DataCon wrappers conlike.
+This is especially true now that we don’t inline DataCon wrappers
+until the final simplifier phase; see Note [Activation for data
+constructor wrappers].
+
+For further reading, see:
+  * Note [Conlike is interesting] in GHC.Core.Op.Simplify.Utils
+  * Note [Lone variables] in GHC.Core.Unfold
+  * Note [exprIsConApp_maybe on data constructors with wrappers]
+    in GHC.Core.SimpleOpt
+  * #18012
 
 Note [Bangs on imported data constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/libraries/parsec b/libraries/parsec
-Subproject ee741870f028e036ab15ae6e2183f09b31e51ae
+Subproject ce416997e15438ca616667995660e123ef7e219
diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr
index 608b26b793..08946c5cd3 100644
--- a/testsuite/tests/deSugar/should_compile/T2431.stderr
+++ b/testsuite/tests/deSugar/should_compile/T2431.stderr
@@ -4,7 +4,7 @@ Result size of Tidy Core
   = {terms: 63, types: 43, coercions: 1, joins: 0/0}
 
 -- RHS size: {terms: 2, types: 4, coercions: 1, joins: 0/0}
-T2431.$WRefl [InlPrag=INLINE[0]] :: forall a. a :~: a
+T2431.$WRefl [InlPrag=INLINE[0] CONLIKE] :: forall a. a :~: a
 [GblId[DataConWrapper],
  Caf=NoCafRefs,
  Cpr=m1,
@@ -110,3 +110,6 @@ T2431.$tc'Refl
       $tc'Refl2
       1#
       $krep3
+
+
+
diff --git a/testsuite/tests/simplCore/should_compile/T18013.stderr b/testsuite/tests/simplCore/should_compile/T18013.stderr
index 677c08e7d9..42f517b9ea 100644
--- a/testsuite/tests/simplCore/should_compile/T18013.stderr
+++ b/testsuite/tests/simplCore/should_compile/T18013.stderr
@@ -120,11 +120,11 @@ Rule fired: mkRule @(_, ()) (T18013a)
 Rule fired: Class op fmap (BUILTIN)
 Rule fired: mkRule @((), _) (T18013a)
 Rule fired: Class op fmap (BUILTIN)
-Rule fired: mkRule @(_, ()) (T18013a)
+Rule fired: mkRule @((), _) (T18013a)
 Rule fired: Class op fmap (BUILTIN)
 Rule fired: mkRule @(_, ()) (T18013a)
 Rule fired: Class op fmap (BUILTIN)
-Rule fired: mkRule @((), _) (T18013a)
+Rule fired: mkRule @(_, ()) (T18013a)
 Rule fired: Class op fmap (BUILTIN)
 
 ==================== Tidy Core ====================
diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr
index 45c88f376e..a5765d480a 100644
--- a/testsuite/tests/simplCore/should_compile/T7360.stderr
+++ b/testsuite/tests/simplCore/should_compile/T7360.stderr
@@ -4,7 +4,7 @@ Result size of Tidy Core
   = {terms: 106, types: 47, coercions: 0, joins: 0/0}
 
 -- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
-T7360.$WFoo3 [InlPrag=INLINE[0]] :: Int -> Foo
+T7360.$WFoo3 [InlPrag=INLINE[0] CONLIKE] :: Int -> Foo
 [GblId[DataConWrapper],
  Arity=1,
  Caf=NoCafRefs,
diff --git a/testsuite/tests/simplCore/should_run/T18012.hs b/testsuite/tests/simplCore/should_run/T18012.hs
new file mode 100644
index 0000000000..9118b75ff4
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T18012.hs
@@ -0,0 +1,41 @@
+module Main (main) where
+
+{- This program is designed to check that case-of-known-constructor
+fires even if an application of a DataCon wrapper is floated out:
+
+  * The early FloatOut pass will float `D False` out of `g`, since
+    it’s a constant, non-trivial expression.
+
+  * But since `D` is strict, the floated-out expression will actually
+    be `$WD False`.
+
+  * In simplifier phase 2, `f` will be inlined into `g`, leading to a
+    case expression that scrutinizes the floated-out binding.
+
+  * If case-of-known-constructor fires, we’ll end up with `notRule
+    False`, the RULE will fire, and we get True.
+
+  * If it doesn’t fire at phase 2, it will fire later at phase 0 when
+    we inline the DataCon wrapper. But now the RULE is inactive, so
+    we’ll end up with False instead.
+
+We want case-of-known-constructor to fire early, so we want the output
+to be True. See #18012 for more details. -}
+
+main :: IO ()
+main = print (g ())
+
+data T = D !Bool
+
+notRule :: Bool -> Bool
+notRule x = x
+{-# INLINE [0] notRule #-}
+{-# RULES "notRule/False" [~0] notRule False = True #-}
+
+f :: T -> () -> Bool
+f (D a) () = notRule a
+{-# INLINE [100] f #-} -- so it isn’t inlined before FloatOut
+
+g :: () -> Bool
+g x = f (D False) x
+{-# NOINLINE g #-}
diff --git a/testsuite/tests/simplCore/should_run/T18012.stdout b/testsuite/tests/simplCore/should_run/T18012.stdout
new file mode 100644
index 0000000000..0ca95142bb
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T18012.stdout
@@ -0,0 +1 @@
+True
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index d101bff84b..210949d9c6 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -93,3 +93,4 @@ test('T15840a', normal, compile_and_run, [''])
 test('T16066', exit_code(1), compile_and_run, ['-O1'])
 test('T17206', exit_code(1), compile_and_run, [''])
 test('T17151', [], multimod_compile_and_run, ['T17151', ''])
+test('T18012', normal, compile_and_run, [''])
diff --git a/testsuite/tests/stranal/should_compile/T16029.stdout b/testsuite/tests/stranal/should_compile/T16029.stdout
index 5aae1ff281..26c2973852 100644
--- a/testsuite/tests/stranal/should_compile/T16029.stdout
+++ b/testsuite/tests/stranal/should_compile/T16029.stdout
@@ -1,4 +1,4 @@
-T16029.$WMkT [InlPrag=INLINE[0]] :: Int -> Int -> T
+T16029.$WMkT [InlPrag=INLINE[0] CONLIKE] :: Int -> Int -> T
          Tmpl= \ (dt [Occ=Once!] :: Int) (dt [Occ=Once!] :: Int) ->
   = \ (dt [Occ=Once!] :: Int) (dt [Occ=Once!] :: Int) ->
   :: GHC.Prim.Int# -> GHC.Prim.Int#