Fix arityType: -fpedantic-bottoms, join points, etcwip/T21694a

This MR fixes #21694, #21755.  It also makes sure that #21948 and
fix to #21694.

* For #21694 the underlying problem was that we were calling arityType
  on an expression that had free join points.  This is a Bad Bad Idea.
  See Note [No free join points in arityType].

* To make "no free join points in arityType" work out I had to avoid
  trying to use eta-expansion for runRW#. This entailed a few changes
  in the Simplifier's treatment of runRW#.  See
  GHC.Core.Opt.Simplify.Iteration Note [No eta-expansion in runRW#]

* I also made andArityType work correctly with -fpedantic-bottoms;
  see Note [Combining case branches: andWithTail].

* Rewrote Note [Combining case branches: optimistic one-shot-ness]

* arityType previously treated join points differently to other
  let-bindings. This patch makes them unform; arityType analyses
  the RHS of all bindings to get its ArityType, and extends am_sigs.

  I realised that, now we have am_sigs giving the ArityType for
  let-bound Ids, we don't need the (pre-dating) special code in
  arityType for join points. But instead we need to extend the env for
  Rec bindings, which weren't doing before.  More uniform now.  See
  Note [arityType for let-bindings].

  This meant we could get rid of ae_joins, and in fact get rid of
  EtaExpandArity altogether.  Simpler.

* And finally, it was the strange treatment of join-point Ids in
  arityType (involving a fake ABot type) that led to a serious bug:
  #21755.  Fixed by this refactoring, which treats them uniformly;
  but without breaking #18328.

  In fact, the arity for recursive join bindings is pretty tricky;
  see the long Note [Arity for recursive join bindings]
  in GHC.Core.Opt.Simplify.Utils.  That led to more refactoring,
  including deciding that an Id could have an Arity that is bigger
  than its JoinArity; see Note [Invariants on join points], item
  2(b) in GHC.Core

* Make sure that the "demand threshold" for join points in DmdAnal
  is no bigger than the join-arity.  In GHC.Core.Opt.DmdAnal see
  Note [Demand signatures are computed for a threshold arity based on idArity]

* I moved GHC.Core.Utils.exprIsDeadEnd into GHC.Core.Opt.Arity,
  where it more properly belongs.

* Remove an old, redundant hack in FloatOut.  The old Note was
  Note [Bottoming floats: eta expansion] in GHC.Core.Opt.SetLevels.

Compile time improves very slightly on average:

Metrics: compile_time/bytes allocated
---------------------------------------------------------------------------------------
  T18223(normal) ghc/alloc    725,808,720    747,839,216  +3.0%  BAD
  T6048(optasm)  ghc/alloc    105,006,104    101,599,472  -3.2% GOOD
  geo. mean                                          -0.2%
  minimum                                            -3.2%
  maximum                                            +3.0%

For some reason Windows was better

   T10421(normal) ghc/alloc    125,888,360    124,129,168  -1.4% GOOD
   T18140(normal) ghc/alloc     85,974,520     83,884,224  -2.4% GOOD
  T18698b(normal) ghc/alloc    236,764,568    234,077,288  -1.1% GOOD
   T18923(normal) ghc/alloc     75,660,528     73,994,512  -2.2% GOOD
    T6048(optasm) ghc/alloc    112,232,512    108,182,520  -3.6% GOOD
  geo. mean                                          -0.6%

I had a quick look at T18223 but it is knee deep in coercions and
the size of everything looks similar before and after.  I decided
to accept that 3% increase in exchange for goodness elsewhere.

Metric Decrease:
    T10421
    T18140
    T18698b
    T18923
    T6048

Metric Increase:
    T18223

1 files changed, 41 insertions, 26 deletions

diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs
index 3f6c212f49..d3cface58c 100644
--- a/compiler/GHC/Core/Tidy.hs
+++ b/compiler/GHC/Core/Tidy.hs
@@ -117,8 +117,7 @@ tidyCbvInfoTop boot_exports id rhs
 
 -- See Note [CBV Function Ids]
 tidyCbvInfoLocal :: HasDebugCallStack => Id -> CoreExpr -> Id
-tidyCbvInfoLocal id rhs
-  | otherwise = computeCbvInfo id rhs
+tidyCbvInfoLocal id rhs = computeCbvInfo id rhs
 
 -- | For a binding we:
 -- * Look at the args
@@ -135,9 +134,9 @@ computeCbvInfo :: HasCallStack
                -> Id
 -- computeCbvInfo fun_id rhs = fun_id
 computeCbvInfo fun_id rhs
-  | (isWorkerLike || isJoinId fun_id) &&  (valid_unlifted_worker val_args)
-  =
-    -- pprTrace "computeCbvInfo"
+  | is_wkr_like || isJust mb_join_id
+  , valid_unlifted_worker val_args
+  = -- pprTrace "computeCbvInfo"
     --   (text "fun" <+> ppr fun_id $$
     --     text "arg_tys" <+> ppr (map idType val_args) $$
 
@@ -146,31 +145,48 @@ computeCbvInfo fun_id rhs
     --     text "cbv_marks" <+> ppr cbv_marks $$
     --     text "out_id" <+> ppr cbv_bndr $$
     --     ppr rhs)
-      cbv_bndr
+    cbv_bndr
+
   | otherwise = fun_id
   where
-    val_args = filter isId . fst $ collectBinders rhs
-    cbv_marks =
-      -- CBV marks are only set during tidy so none should be present already.
-      assertPpr (maybe True null $ idCbvMarks_maybe fun_id) (ppr fun_id <+> (ppr $ idCbvMarks_maybe fun_id) $$ ppr rhs) $
-      map mkMark val_args
-    cbv_bndr
-        | valid_unlifted_worker val_args
-        , any isMarkedCbv cbv_marks
-        -- seqList to avoid retaining the original rhs
-        = cbv_marks `seqList` setIdCbvMarks fun_id cbv_marks
-        | otherwise =
-          -- pprTraceDebug "tidyCbvInfo: Worker seems to take unboxed tuple/sum types!" (ppr fun_id <+> ppr rhs)
-          asNonWorkerLikeId fun_id
-    -- We don't set CBV marks on functions which take unboxed tuples or sums as arguments.
-    -- Doing so would require us to compute the result of unarise here in order to properly determine
-    -- argument positions at runtime.
-    -- In practice this doesn't matter much. Most "interesting" functions will get a W/W split which will eliminate
-    -- unboxed tuple arguments, and unboxed sums are rarely used. But we could change this in the future and support
+    mb_join_id  = isJoinId_maybe fun_id
+    is_wkr_like = isWorkerLikeId fun_id
+
+    val_args = filter isId lam_bndrs
+    -- When computing CbvMarks, we limit the arity of join points to
+    -- the JoinArity, because that's the arity we are going to use
+    -- when calling it. There may be more lambdas than that on the RHS.
+    lam_bndrs | Just join_arity <- mb_join_id
+              = fst $ collectNBinders join_arity rhs
+              | otherwise
+              = fst $ collectBinders rhs
+
+    cbv_marks = -- assert: CBV marks are only set during tidy so none should be present already.
+                assertPpr (maybe True null $ idCbvMarks_maybe fun_id)
+                          (ppr fun_id <+> (ppr $ idCbvMarks_maybe fun_id) $$ ppr rhs) $
+                map mkMark val_args
+
+    cbv_bndr | any isMarkedCbv cbv_marks
+             = cbv_marks `seqList` setIdCbvMarks fun_id cbv_marks
+               -- seqList: avoid retaining the original rhs
+
+             | otherwise
+             = -- pprTraceDebug "tidyCbvInfo: Worker seems to take unboxed tuple/sum types!"
+               --    (ppr fun_id <+> ppr rhs)
+               asNonWorkerLikeId fun_id
+
+    -- We don't set CBV marks on functions which take unboxed tuples or sums as
+    -- arguments.  Doing so would require us to compute the result of unarise
+    -- here in order to properly determine argument positions at runtime.
+    --
+    -- In practice this doesn't matter much. Most "interesting" functions will
+    -- get a W/W split which will eliminate unboxed tuple arguments, and unboxed
+    -- sums are rarely used. But we could change this in the future and support
     -- unboxed sums/tuples as well.
     valid_unlifted_worker args =
       -- pprTrace "valid_unlifted" (ppr fun_id $$ ppr args) $
       all isSingleUnarisedArg args
+
     isSingleUnarisedArg v
       | isUnboxedSumType ty = False
       | isUnboxedTupleType ty = isSimplePrimRep (typePrimRep ty)
@@ -188,7 +204,6 @@ computeCbvInfo fun_id rhs
       , not (isDeadEndId fun_id) = MarkedCbv
       | otherwise = NotMarkedCbv
 
-    isWorkerLike = isWorkerLikeId fun_id
 
 ------------  Expressions  --------------
 tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr
@@ -339,7 +354,7 @@ tidyLetBndr rec_tidy_env env@(tidy_env, var_env) id
         new_info = vanillaIdInfo
                     `setOccInfo`        occInfo old_info
                     `setArityInfo`      arityInfo old_info
-                    `setDmdSigInfo` zapDmdEnvSig (dmdSigInfo old_info)
+                    `setDmdSigInfo`     zapDmdEnvSig (dmdSigInfo old_info)
                     `setDemandInfo`     demandInfo old_info
                     `setInlinePragInfo` inlinePragInfo old_info
                     `setUnfoldingInfo`  new_unf