diff options
| -rw-r--r-- | compiler/coreSyn/CoreArity.hs | 13 | ||||
| -rw-r--r-- | testsuite/tests/stranal/should_compile/Makefile | 4 | ||||
| -rw-r--r-- | testsuite/tests/stranal/should_compile/T13031.hs | 11 | ||||
| -rw-r--r-- | testsuite/tests/stranal/should_compile/T13031.stdout | 4 | ||||
| -rw-r--r-- | testsuite/tests/stranal/should_compile/all.T | 5 |
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']) + |