Fix a bug in ABot handling in CoreArity

See Note [ABot branches: use max] in CoreArity.

I stumbled on this when investigating something else, and
opened Trac #13031 to track it.

It's very hard to tickle the bug, which is why it has lurked so long,
but the test
   stranal/should_compile/T13031
does so

Oddly, the testsuite framework doesn't actually run the test; I have
no idea why.

5 files changed, 33 insertions, 4 deletions

diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs
index f5e76736ce..e6b1f113eb 100644
--- a/compiler/coreSyn/CoreArity.hs
+++ b/compiler/coreSyn/CoreArity.hs
@@ -654,8 +654,7 @@ arityApp (ATop [])     _     = ATop []
 arityApp (ATop (_:as)) cheap = floatIn cheap (ATop as)
 
 andArityType :: ArityType -> ArityType -> ArityType   -- Used for branches of a 'case'
-andArityType (ABot n1) (ABot n2)
-  = ABot (n1 `min` n2)
+andArityType (ABot n1) (ABot n2)  = ABot (n1 `max` n2) -- Note [ABot branches: use max]
 andArityType (ATop as)  (ABot _)  = ATop as
 andArityType (ABot _)   (ATop bs) = ATop bs
 andArityType (ATop as)  (ATop bs) = ATop (as `combine` bs)
@@ -664,7 +663,15 @@ andArityType (ATop as)  (ATop bs) = ATop (as `combine` bs)
     combine []     bs     = takeWhile isOneShotInfo bs
     combine as     []     = takeWhile isOneShotInfo as
 
-{-
+{- Note [ABot branches: use max]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider   case x of
+             True  -> \x.  error "urk"
+             False -> \xy. error "urk2"
+
+Remember: ABot n means "if you apply to n args, it'll definitely diverge".
+So we need (ABot 2) for the whole thing, the /max/ of the ABot arities.
+
 Note [Combining case branches]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
diff --git a/testsuite/tests/stranal/should_compile/Makefile b/testsuite/tests/stranal/should_compile/Makefile
index 9101fbd40a..16d1f2f84a 100644
--- a/testsuite/tests/stranal/should_compile/Makefile
+++ b/testsuite/tests/stranal/should_compile/Makefile
@@ -1,3 +1,7 @@
 TOP=../../..
 include $(TOP)/mk/boilerplate.mk
 include $(TOP)/mk/test.mk
+
+T13031:
+	echo hello
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c -fforce-recomp T13031.hs -ddump-simpl | grep 'Arity='
diff --git a/testsuite/tests/stranal/should_compile/T13031.hs b/testsuite/tests/stranal/should_compile/T13031.hs
new file mode 100644
index 0000000000..d5fe761b34
--- /dev/null
+++ b/testsuite/tests/stranal/should_compile/T13031.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE MagicHash #-}
+
+module Foo( f ) where
+import GHC.Prim
+
+f True  = raise# True
+f False = \p q -> raise# False
+
+
+
+
diff --git a/testsuite/tests/stranal/should_compile/T13031.stdout b/testsuite/tests/stranal/should_compile/T13031.stdout
new file mode 100644
index 0000000000..b6b9f61458
--- /dev/null
+++ b/testsuite/tests/stranal/should_compile/T13031.stdout
@@ -0,0 +1,4 @@
+echo hello
+hello
+'/5playpen/simonpj/HEAD-4/inplace/test   spaces/ghc-stage2' -dcore-lint -dcmm-lint -no-user-package-db -rtsopts  -fno-warn-missed-specialisations -fshow-warning-groups -fdiagnostics-color=never -dno-debug-output -c -fforce-recomp T13031.hs -ddump-simpl | grep 'Arity='
+[GblId, Arity=1, Caf=NoCafRefs]
diff --git a/testsuite/tests/stranal/should_compile/all.T b/testsuite/tests/stranal/should_compile/all.T
index 0f57c3bb62..6cd9da4114 100644
--- a/testsuite/tests/stranal/should_compile/all.T
+++ b/testsuite/tests/stranal/should_compile/all.T
@@ -37,7 +37,7 @@ test('T8743', [ extra_clean(['T8743.o-boot', 'T8743a.hi', 'T8743a.o', 'T8743.hi-
 #   The intent here is to check that $wfoo has type
 #         $wfoo :: Int# -> Int# -> Int
 #   with two unboxed args.  See Trac #10482 for background
-# 
+#
 # Set -dppr-cols to ensure output doesn't wrap
 test('T10482',  [ grepCoreString(r'wfoo.*Int#') ], compile, ['-dppr-cols=200 -ddump-simpl'])
 test('T10482a', [ grepCoreString(r'wf.*Int#') ],   compile, ['-dppr-cols=200 -ddump-simpl'])
@@ -49,4 +49,7 @@ test('T9208', when(compiler_debugged(), expect_broken(9208)), compile, [''])
 test('T10694', [ grepCoreString(r'Str=') ],   compile, ['-dppr-cols=200 -ddump-simpl'])
 test('T11770', [ checkCoreString('OneShot') ], compile, ['-ddump-simpl'])
 
+test('T13031', normal, run_command,
+         ['$MAKE -s --no-print-directory T13031'])
+