CallArity: Consider shadowing introduced by case and field binders

In #20283, we saw a regression in `simple` due to CallArity for a very subtle
reason: It simply didn't handle shadowing of case binders and constructor field
binders!

The test case T20283 has a very interesting binding `n_X1` that we want to
eta-expand and that has a Unique (on GHC HEAD) that is reused by the Simplifier
for a case binder:
```
  let { n_X1 = ... } in
    ...
      let {
        lvl_s1Ul
          = ... case x_a1Rg of wild_X1 {
                  __DEFAULT -> f_s1Tx rho_value_awA (GHC.Types.I# wild_X1);
                  0# -> lvl_s1TN
                } ...
          } in
      letrec {
        go3_X3
          = \ (x_X4 :: GHC.Prim.Int#) (v_a1P9 [OS=OneShot] :: Double) ->
              let {
                karg_s1Wu = ...
                                    case lvl_s1Ul of { GHC.Types.D# y_a1Qf ->
                            ...
                    } } in
              case GHC.Prim.==# x_X4 y_a1R7 of {
                __DEFAULT -> go3_X3 (GHC.Prim.+# x_X4 1#) karg_s1Wu;
                1# -> n_X1 karg_s1Wu -- Here we will assume that karg calls n_X1!
              }; } in
      go3_X3 0#;
```

Since the Case case of CallArity doesn't delete `X1` from the set of variables
it is interested in knowing the usages of, we leak a very boring usage (of the
case binder!) into the co-call graph that we mistakenly take for a usage of
`n_X1`. We conclude that `lvl_s1Ul` and transitively `karg_s1Wu` call `n_X1`
when really they don't. That culminates in the conclusion that `n_X1 karg_s1Wu`
calls `n_X1` more than once. Wrong!

Fortunately, this bug (which has been there right from CallArity's inception,
I suppose) will never lead to a CallArity that is too optimistic. So by fixing
this bug, we get strictly more opportunities for CallArity and all of them
should be sound to exploit.

Fixes #20283.

4 files changed, 35 insertions, 1 deletions

diff --git a/compiler/GHC/Core/Opt/CallArity.hs b/compiler/GHC/Core/Opt/CallArity.hs
index 254b215537..d8d9749941 100644
--- a/compiler/GHC/Core/Opt/CallArity.hs
+++ b/compiler/GHC/Core/Opt/CallArity.hs
@@ -525,7 +525,7 @@ callArityAnal arity int (Case scrut bndr ty alts)
       (final_ae, Case scrut' bndr ty alts')
   where
     (alt_aes, alts') = unzip $ map go alts
-    go (Alt dc bndrs e) = let (ae, e') = callArityAnal arity int e
+    go (Alt dc bndrs e) = let (ae, e') = callArityAnal arity (int `delVarSetList` (bndr:bndrs)) e
                           in  (ae, Alt dc bndrs e')
     alt_ae = lubRess alt_aes
     (scrut_ae, scrut') = callArityAnal 0 int scrut
diff --git a/testsuite/tests/callarity/should_compile/Makefile b/testsuite/tests/callarity/should_compile/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/callarity/should_compile/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/callarity/should_compile/T20283.hs b/testsuite/tests/callarity/should_compile/T20283.hs
new file mode 100644
index 0000000000..658bbf3c50
--- /dev/null
+++ b/testsuite/tests/callarity/should_compile/T20283.hs
@@ -0,0 +1,23 @@
+module T20283 where
+
+import Data.Array
+
+polynomial ::  (Array (Int, Int) (Array (Int, Int) Double)) -> Int -> (Array Int Double) -> (Array Int Double) -> Double -> Double -> Double
+polynomial g degree rho_table theta_table rho_value theta_value =
+
+   let {
+       table_search table value =
+          let {
+              (low, high) = bounds table ;
+              search_down i = if value > (table!(i - 1)) then
+                                i else search_down (i - 1)
+              } in if value > (table!high) then
+                     high + 1 else if value <= (table!low) then
+                                     low else search_down high ;
+       rho_index = table_search rho_table rho_value ;
+       theta_index = table_search theta_table theta_value ;
+       a = g!(rho_index, theta_index)
+       } in foldl (+) 0 [ ((a!(i, j)) * rho_value ^ (i::Int))
+                          * theta_value ^ j | i <- [0..degree],
+                                              j <- [0..degree] ]
+
diff --git a/testsuite/tests/callarity/should_compile/all.T b/testsuite/tests/callarity/should_compile/all.T
new file mode 100644
index 0000000000..88f16ec629
--- /dev/null
+++ b/testsuite/tests/callarity/should_compile/all.T
@@ -0,0 +1,8 @@
+# Only compile with optimisation
+setTestOpts( only_ways(['optasm']) )
+
+# The gist here is that the n_X1 :: Double -> Double binding we see in
+# CallArity will be eta-expanded, inlined and thus not be seen in simplified
+# output. There should be no other Double -> Double bindings, so testing for
+# the absence of the sig should be reasonably precise.
+test('T20283',  [ grep_errmsg(r':: Double -> Double') ], compile, ['-dppr-cols=1000 -ddump-simpl'])