Remove ad-hoc special case in occAnal

Back in 1999 I put this ad-hoc code in the Case-handling
code for occAnal:

  occAnal env (Case scrut bndr ty alts)
   = ...
        -- Note [Case binder usage]
        -- ~~~~~~~~~~~~~~~~~~~~~~~~
        -- The case binder gets a usage of either "many" or "dead", never "one".
        -- Reason: we like to inline single occurrences, to eliminate a binding,
        -- but inlining a case binder *doesn't* eliminate a binding.
        -- We *don't* want to transform
        --      case x of w { (p,q) -> f w }
        -- into
        --      case x of w { (p,q) -> f (p,q) }
    tag_case_bndr usage bndr
      = (usage', setIdOccInfo bndr final_occ_info)
      where
        occ_info       = lookupDetails usage bndr
        usage'         = usage `delDetails` bndr
        final_occ_info = case occ_info of IAmDead -> IAmDead
                                          _       -> noOccInfo

But the comment looks wrong -- the bad inlining will not happen -- and
I think it relates to some long-ago version of the simplifier.

So I simply removed the special case, which gives more accurate
occurrence-info to the case binder.  Interestingly I got a slight
improvement in nofib binary sizes.

--------------------------------------------------------------------------------
        Program           Size    Allocs   Runtime   Elapsed  TotalMem
--------------------------------------------------------------------------------
      cacheprof          -0.1%     +0.2%     -0.7%     -1.2%     +8.6%
--------------------------------------------------------------------------------
            Min          -0.2%      0.0%    -14.5%    -30.5%      0.0%
            Max          -0.1%     +0.2%    +10.0%    +10.0%    +25.0%
 Geometric Mean          -0.2%     +0.0%     -1.9%     -5.4%     +0.3%

I have no idea if the improvement in runtime is real.  I did look at the
tiny increase in allocation for cacheprof and concluded that it was
unimportant (I forget the details).

Also the more accurate occ-info for the case binder meant that some
inlining happens in one pass that previously took successive passes
for the test dependent/should_compile/dynamic-paper (which has a
known Russel-paradox infinite loop in the simplifier).

In short, a small win: less ad-hoc complexity and slightly smaller
binaries.

10 files changed, 55 insertions, 49 deletions

diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs
index 8ffb6bed69..a8cfbc0868 100644
--- a/compiler/simplCore/OccurAnal.hs
+++ b/compiler/simplCore/OccurAnal.hs
@@ -1772,29 +1772,12 @@ occAnal env (Case scrut bndr ty alts)
     case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts')   ->
     let
         alts_usage  = foldr orUDs emptyDetails alts_usage_s
-        (alts_usage1, tagged_bndr) = tag_case_bndr alts_usage bndr
+        (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr
         total_usage = markAllNonTailCalled scrut_usage `andUDs` alts_usage1
                         -- Alts can have tail calls, but the scrutinee can't
     in
     total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
   where
-        -- Note [Case binder usage]
-        -- ~~~~~~~~~~~~~~~~~~~~~~~~
-        -- The case binder gets a usage of either "many" or "dead", never "one".
-        -- Reason: we like to inline single occurrences, to eliminate a binding,
-        -- but inlining a case binder *doesn't* eliminate a binding.
-        -- We *don't* want to transform
-        --      case x of w { (p,q) -> f w }
-        -- into
-        --      case x of w { (p,q) -> f (p,q) }
-    tag_case_bndr usage bndr
-      = (usage', setIdOccInfo bndr final_occ_info)
-      where
-        occ_info       = lookupDetails usage bndr
-        usage'         = usage `delDetails` bndr
-        final_occ_info = case occ_info of IAmDead -> IAmDead
-                                          _       -> noOccInfo
-
     alt_env = mkAltEnv env scrut bndr
     occ_anal_alt = occAnalAlt alt_env
 
@@ -2023,10 +2006,9 @@ occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr))
 occAnalAlt (env, scrut_bind) (con, bndrs, rhs)
   = case occAnal env rhs of { (rhs_usage1, rhs1) ->
     let
-        (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs
-                                  -- See Note [Binders in case alternatives]
-        (alt_usg', rhs2) =
-          wrapAltRHS env scrut_bind alt_usg tagged_bndrs rhs1
+      (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs
+                                -- See Note [Binders in case alternatives]
+      (alt_usg', rhs2) = wrapAltRHS env scrut_bind alt_usg tagged_bndrs rhs1
     in
     (alt_usg', (con, tagged_bndrs, rhs2)) }
 
@@ -2044,12 +2026,16 @@ wrapAltRHS env (Just (scrut_var, let_rhs)) alt_usg bndrs alt_rhs
   = ( alt_usg' `andUDs` let_rhs_usg
     , Let (NonRec tagged_scrut_var let_rhs') alt_rhs )
   where
-    captured = any (`usedIn` let_rhs_usg) bndrs
+    captured = any (`usedIn` let_rhs_usg) bndrs  -- Check condition (b)
+
     -- The rhs of the let may include coercion variables
     -- if the scrutinee was a cast, so we must gather their
     -- usage. See Note [Gather occurrences of coercion variables]
+    -- Moreover, the rhs of the let may mention the case-binder, and
+    -- we want to gather its occ-info as well
     (let_rhs_usg, let_rhs') = occAnal env let_rhs
-    (alt_usg', [tagged_scrut_var]) = tagLamBinders alt_usg [scrut_var]
+
+    (alt_usg', tagged_scrut_var) = tagLamBinder alt_usg scrut_var
 
 wrapAltRHS _ _ alt_usg _ alt_rhs
   = (alt_usg, alt_rhs)
@@ -2372,10 +2358,10 @@ information right.
 -}
 
 mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr))
--- Does two things: a) makes the occ_one_shots = OccVanilla
---                  b) extends the GlobalScruts if possible
---                  c) returns a proxy mapping, binding the scrutinee
---                     to the case binder, if possible
+-- Does three things: a) makes the occ_one_shots = OccVanilla
+--                    b) extends the GlobalScruts if possible
+--                    c) returns a proxy mapping, binding the scrutinee
+--                       to the case binder, if possible
 mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr
   = case stripTicksTopE (const True) scrut of
       Var v           -> add_scrut v case_bndr'
@@ -2384,15 +2370,19 @@ mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr
       _               -> (env { occ_encl = OccVanilla }, Nothing)
 
   where
-    add_scrut v rhs = ( env { occ_encl = OccVanilla, occ_gbl_scrut = pe `extendVarSet` v }
+    add_scrut v rhs = ( env { occ_encl = OccVanilla
+                            , occ_gbl_scrut = pe `extendVarSet` v }
                       , Just (localise v, rhs) )
 
-    case_bndr' = Var (zapIdOccInfo case_bndr) -- See Note [Zap case binders in proxy bindings]
-    localise scrut_var = mkLocalIdOrCoVar (localiseName (idName scrut_var)) (idType scrut_var)
-        -- Localise the scrut_var before shadowing it; we're making a
-        -- new binding for it, and it might have an External Name, or
-        -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees]
-        -- Also we don't want any INLINE or NOINLINE pragmas!
+    case_bndr' = Var (zapIdOccInfo case_bndr)
+                   -- See Note [Zap case binders in proxy bindings]
+
+    -- Localise the scrut_var before shadowing it; we're making a
+    -- new binding for it, and it might have an External Name, or
+    -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees]
+    -- Also we don't want any INLINE or NOINLINE pragmas!
+    localise scrut_var = mkLocalIdOrCoVar (localiseName (idName scrut_var))
+                                          (idType scrut_var)
 
 {-
 ************************************************************************
@@ -2592,14 +2582,21 @@ tagLamBinders :: UsageDetails          -- Of scope
               -> [Id]                  -- Binders
               -> (UsageDetails,        -- Details with binders removed
                  [IdWithOccInfo])    -- Tagged binders
+tagLamBinders usage binders
+  = usage' `seq` (usage', bndrs')
+  where
+    (usage', bndrs') = mapAccumR tagLamBinder usage binders
+
+tagLamBinder :: UsageDetails       -- Of scope
+             -> Id                 -- Binder
+             -> (UsageDetails,     -- Details with binder removed
+                 IdWithOccInfo)    -- Tagged binders
 -- Used for lambda and case binders
 -- It copes with the fact that lambda bindings can have a
 -- stable unfolding, used for join points
-tagLamBinders usage binders = usage' `seq` (usage', bndrs')
+tagLamBinder usage bndr
+  = (usage2, bndr')
   where
-    (usage', bndrs') = mapAccumR tag_lam usage binders
-    tag_lam usage bndr = (usage2, bndr')
-      where
         occ    = lookupDetails usage bndr
         bndr'  = setBinderOcc (markNonTailCalled occ) bndr
                    -- Don't try to make an argument into a join point
diff --git a/testsuite/tests/codeGen/should_compile/T14626.stdout b/testsuite/tests/codeGen/should_compile/T14626.stdout
index 31e280e062..389d3e733a 100644
--- a/testsuite/tests/codeGen/should_compile/T14626.stdout
+++ b/testsuite/tests/codeGen/should_compile/T14626.stdout
@@ -1,2 +1,2 @@
-      case dt of dt { __DEFAULT -> T14626.MkT dt }
+      case dt of dt [Occ=Once] { __DEFAULT -> T14626.MkT dt }
       case v of { T14626.MkT y [Occ=Once] ->
diff --git a/testsuite/tests/dependent/should_compile/all.T b/testsuite/tests/dependent/should_compile/all.T
index 66221840bb..e153cafe41 100644
--- a/testsuite/tests/dependent/should_compile/all.T
+++ b/testsuite/tests/dependent/should_compile/all.T
@@ -17,7 +17,7 @@ test('T9632', normal, compile, [''])
 # discussed in #11330.
 test('dynamic-paper',
      expect_broken_for(11330, ['profasm']),
-     compile, [''])
+     compile_fail, [''])
 test('T11311', normal, compile, [''])
 test('T11405', normal, compile, [''])
 test('T11241', normal, compile, [''])
diff --git a/testsuite/tests/dependent/should_compile/dynamic-paper.stderr b/testsuite/tests/dependent/should_compile/dynamic-paper.stderr
new file mode 100644
index 0000000000..0519ecba6e
--- /dev/null
+++ b/testsuite/tests/dependent/should_compile/dynamic-paper.stderr
@@ -0,0 +1 @@
+ 
\ No newline at end of file
diff --git a/testsuite/tests/simplCore/should_compile/T13143.stderr b/testsuite/tests/simplCore/should_compile/T13143.stderr
index 160a4a2c93..d8b0c1b468 100644
--- a/testsuite/tests/simplCore/should_compile/T13143.stderr
+++ b/testsuite/tests/simplCore/should_compile/T13143.stderr
@@ -105,7 +105,9 @@ g [InlPrag=NOUSERINLINE[2]] :: Bool -> Bool -> Int -> Int
                  (w1 [Occ=Once] :: Bool)
                  (w2 [Occ=Once!] :: Int) ->
                  case w2 of { GHC.Types.I# ww1 [Occ=Once] ->
-                 case T13143.$wg w w1 ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
+                 case T13143.$wg w w1 ww1 of ww2 [Occ=Once] { __DEFAULT ->
+                 GHC.Types.I# ww2
+                 }
                  }}]
 g = \ (w :: Bool) (w1 :: Bool) (w2 :: Int) ->
       case w2 of { GHC.Types.I# ww1 ->
diff --git a/testsuite/tests/simplCore/should_compile/T3717.stderr b/testsuite/tests/simplCore/should_compile/T3717.stderr
index a271850abf..45fdf89bb4 100644
--- a/testsuite/tests/simplCore/should_compile/T3717.stderr
+++ b/testsuite/tests/simplCore/should_compile/T3717.stderr
@@ -71,7 +71,9 @@ foo [InlPrag=NOUSERINLINE[2]] :: Int -> Int
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
          Tmpl= \ (w [Occ=Once!] :: Int) ->
                  case w of { GHC.Types.I# ww1 [Occ=Once] ->
-                 case T3717.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
+                 case T3717.$wfoo ww1 of ww2 [Occ=Once] { __DEFAULT ->
+                 GHC.Types.I# ww2
+                 }
                  }}]
 foo
   = \ (w :: Int) ->
diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr
index 02e8a6c65e..7556ecc9af 100644
--- a/testsuite/tests/simplCore/should_compile/T4930.stderr
+++ b/testsuite/tests/simplCore/should_compile/T4930.stderr
@@ -71,7 +71,9 @@ foo [InlPrag=NOUSERINLINE[2]] :: Int -> Int
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
          Tmpl= \ (w [Occ=Once!] :: Int) ->
                  case w of { GHC.Types.I# ww1 [Occ=Once] ->
-                 case T4930.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
+                 case T4930.$wfoo ww1 of ww2 [Occ=Once] { __DEFAULT ->
+                 GHC.Types.I# ww2
+                 }
                  }}]
 foo
   = \ (w :: Int) ->
diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr
index 8ae5953b43..f310e8f7a8 100644
--- a/testsuite/tests/simplCore/should_compile/T7360.stderr
+++ b/testsuite/tests/simplCore/should_compile/T7360.stderr
@@ -57,10 +57,10 @@ fun2 :: forall a. [a] -> ((), Int)
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
          Tmpl= \ (@ a) (x [Occ=Once!] :: [a]) ->
                  (T7360.fun5,
-                  case x of wild {
+                  case x of wild [Occ=Once] {
                     [] -> T7360.fun4;
                     : _ [Occ=Dead] _ [Occ=Dead] ->
-                      case GHC.List.$wlenAcc @ a wild 0# of ww2 { __DEFAULT ->
+                      case GHC.List.$wlenAcc @ a wild 0# of ww2 [Occ=Once] { __DEFAULT ->
                       GHC.Types.I# ww2
                       }
                   })}]
diff --git a/testsuite/tests/simplCore/should_compile/T7865.stdout b/testsuite/tests/simplCore/should_compile/T7865.stdout
index 7ea5449fbe..4073fec7ad 100644
--- a/testsuite/tests/simplCore/should_compile/T7865.stdout
+++ b/testsuite/tests/simplCore/should_compile/T7865.stdout
@@ -1,7 +1,7 @@
 T7865.$wexpensive [InlPrag=NOINLINE]
 T7865.$wexpensive
 expensive [InlPrag=NOUSERINLINE[0]] :: Int -> Int
-                 case T7865.$wexpensive ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
+                 case T7865.$wexpensive ww1 of ww2 [Occ=Once] { __DEFAULT ->
 expensive
       case T7865.$wexpensive ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
             case T7865.$wexpensive ww1 of ww2 { __DEFAULT ->
diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
index 0b0c79695a..65dd9a1aa0 100644
--- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr
+++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
@@ -144,7 +144,9 @@ Roman.foo_go [InlPrag=NOUSERINLINE[2]]
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
          Tmpl= \ (w [Occ=Once] :: Maybe Int) (w1 [Occ=Once] :: Maybe Int) ->
-                 case Roman.$wgo w w1 of ww { __DEFAULT -> GHC.Types.I# ww }}]
+                 case Roman.$wgo w w1 of ww [Occ=Once] { __DEFAULT ->
+                 GHC.Types.I# ww
+                 }}]
 Roman.foo_go
   = \ (w :: Maybe Int) (w1 :: Maybe Int) ->
       case Roman.$wgo w w1 of ww { __DEFAULT -> GHC.Types.I# ww }
@@ -177,7 +179,7 @@ foo :: Int -> Int
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
          Tmpl= \ (n [Occ=Once!] :: Int) ->
-                 case n of n1 { GHC.Types.I# _ [Occ=Dead] ->
+                 case n of n1 [Occ=Once] { GHC.Types.I# _ [Occ=Dead] ->
                  Roman.foo_go (GHC.Base.Just @ Int n1) Roman.foo1
                  }}]
 foo