Eta expand through CallStacks

This patch fixes #20103, by treating HasCallStack constraints as
cheap when eta-expanding.

See Note [Eta expanding through CallStacks] in GHC.Core.Opt.Arity

3 files changed, 162 insertions, 0 deletions

diff --git a/testsuite/tests/simplCore/should_compile/T20103.hs b/testsuite/tests/simplCore/should_compile/T20103.hs
new file mode 100644
index 0000000000..e19ca5d127
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T20103.hs
@@ -0,0 +1,8 @@
+module T20103 where
+
+import GHC.Stack
+
+foo :: HasCallStack => Int -> Int
+foo 0 = length . fst . head $ getCallStack callStack
+foo n = foo (n-1)
+
diff --git a/testsuite/tests/simplCore/should_compile/T20103.stderr b/testsuite/tests/simplCore/should_compile/T20103.stderr
new file mode 100644
index 0000000000..251a3e60fa
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T20103.stderr
@@ -0,0 +1,153 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 98, types: 59, coercions: 14, joins: 0/0}
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[GblId, Unf=OtherCon []]
+lvl = GHC.Types.I# 12#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl1 :: Int
+[GblId, Unf=OtherCon []]
+lvl1 = GHC.Types.I# 7#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl2 :: Int
+[GblId, Unf=OtherCon []]
+lvl2 = GHC.Types.I# 9#
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+lvl3 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []]
+lvl3 = "T20103.hs"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl4 :: [Char]
+[GblId]
+lvl4 = GHC.CString.unpackCString# lvl3
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T20103.$trModule2 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T20103.$trModule2 = "T20103"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl5 :: [Char]
+[GblId]
+lvl5 = GHC.CString.unpackCString# T20103.$trModule2
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T20103.$trModule4 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+T20103.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl6 :: [Char]
+[GblId]
+lvl6 = GHC.CString.unpackCString# T20103.$trModule4
+
+-- RHS size: {terms: 8, types: 0, coercions: 0, joins: 0/0}
+lvl7 :: SrcLoc
+[GblId, Unf=OtherCon []]
+lvl7 = GHC.Stack.Types.SrcLoc lvl6 lvl5 lvl4 lvl1 lvl2 lvl1 lvl
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+lvl8 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []]
+lvl8 = "foo"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl9 :: [Char]
+[GblId]
+lvl9 = GHC.CString.unpackCString# lvl8
+
+Rec {
+-- RHS size: {terms: 36, types: 29, coercions: 14, joins: 0/0}
+T20103.$wfoo [InlPrag=[2], Occ=LoopBreaker]
+  :: HasCallStack => GHC.Prim.Int# -> GHC.Prim.Int#
+[GblId, Arity=2, Str=<1L><1L>, Unf=OtherCon []]
+T20103.$wfoo
+  = \ ($dIP :: HasCallStack) (ww :: GHC.Prim.Int#) ->
+      case ww of ds {
+        __DEFAULT ->
+          case $dIP
+               `cast` (GHC.Classes.N:IP[0] <"callStack">_N <CallStack>_N
+                       :: (?callStack::CallStack) ~R# CallStack)
+          of wild1 {
+            __DEFAULT ->
+              T20103.$wfoo
+                ((GHC.Stack.Types.PushCallStack lvl9 lvl7 wild1)
+                 `cast` (Sym (GHC.Classes.N:IP[0] <"callStack">_N <CallStack>_N)
+                         :: CallStack ~R# (?callStack::CallStack)))
+                (GHC.Prim.-# ds 1#);
+            GHC.Stack.Types.FreezeCallStack ds1 ->
+              T20103.$wfoo
+                (wild1
+                 `cast` (Sym (GHC.Classes.N:IP[0] <"callStack">_N <CallStack>_N)
+                         :: CallStack ~R# (?callStack::CallStack)))
+                (GHC.Prim.-# ds 1#)
+          };
+        0# ->
+          case getCallStack
+                 ($dIP
+                  `cast` (GHC.Classes.N:IP[0] <"callStack">_N <CallStack>_N
+                          :: (?callStack::CallStack) ~R# CallStack))
+          of {
+            [] -> case GHC.List.badHead of wild1 { };
+            : x ds1 -> case x of { (x1, ds2) -> GHC.List.$wlenAcc @Char x1 0# }
+          }
+      }
+end Rec }
+
+-- RHS size: {terms: 12, types: 5, coercions: 0, joins: 0/0}
+foo [InlPrag=[2]] :: HasCallStack => Int -> Int
+[GblId,
+ Arity=2,
+ Str=<1L><1P(1L)>,
+ Cpr=1,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
+         Tmpl= \ ($dIP [Occ=Once1] :: HasCallStack)
+                 (eta [Occ=Once1!] :: Int) ->
+                 case eta of { GHC.Types.I# ww [Occ=Once1] ->
+                 case T20103.$wfoo $dIP ww of ww1 [Occ=Once1] { __DEFAULT ->
+                 GHC.Types.I# ww1
+                 }
+                 }}]
+foo
+  = \ ($dIP :: HasCallStack) (eta :: Int) ->
+      case eta of { GHC.Types.I# ww ->
+      case T20103.$wfoo $dIP ww of ww1 { __DEFAULT -> GHC.Types.I# ww1 }
+      }
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T20103.$trModule3 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T20103.$trModule3 = GHC.Types.TrNameS T20103.$trModule4
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T20103.$trModule1 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T20103.$trModule1 = GHC.Types.TrNameS T20103.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T20103.$trModule :: GHC.Types.Module
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T20103.$trModule
+  = GHC.Types.Module T20103.$trModule3 T20103.$trModule1
+
+
+
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 8bbf16627a..2fe050e1ba 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -363,6 +363,7 @@ test('T13873',  [ grep_errmsg(r'SPEC') ], compile, ['-O -ddump-rules'])
 # Look for a specialisation rule for wimwam
 test('T19672', normal, compile, ['-O2 -ddump-rules'])
 
+test('T20103',  [ grep_errmsg(r'Arity') ], compile, ['-O -ddump-simpl -dsuppress-uniques'])
 test('T19780', normal, compile, ['-O2'])
 test('T19794', normal, compile, ['-O'])
 test('T19890',  [ grep_errmsg(r'= T19890.foo1') ], compile, ['-O -ddump-simpl'])