diff options
Diffstat (limited to 'testsuite')
11 files changed, 187 insertions, 2 deletions
diff --git a/testsuite/tests/perf/compiler/T16473.stdout b/testsuite/tests/perf/compiler/T16473.stdout index e70603e56f..2e2c88f82c 100644 --- a/testsuite/tests/perf/compiler/T16473.stdout +++ b/testsuite/tests/perf/compiler/T16473.stdout @@ -92,6 +92,12 @@ Rule fired: Class op $p1Monad (BUILTIN) Rule fired: Class op $p1Applicative (BUILTIN) Rule fired: Class op fmap (BUILTIN) Rule fired: Class op fmap (BUILTIN) +Rule fired: Class op fmap (BUILTIN) +Rule fired: Class op fmap (BUILTIN) +Rule fired: SPEC/Main $fFunctorStateT_$cfmap @Identity _ (Main) +Rule fired: Class op fmap (BUILTIN) +Rule fired: SPEC/Main $fFunctorStateT_$cfmap @Identity _ (Main) +Rule fired: Class op fmap (BUILTIN) Rule fired: Class op return (BUILTIN) Rule fired: Class op return (BUILTIN) Rule fired: Class op >>= (BUILTIN) @@ -117,18 +123,19 @@ Rule fired: SPEC/Main $fApplicativeStateT_$c<*> @Identity _ (Main) Rule fired: SPEC/Main $fApplicativeStateT_$c*> @Identity _ (Main) Rule fired: SPEC/Main $fMonadStateT @Identity _ (Main) Rule fired: Class op $p1Monad (BUILTIN) +Rule fired: Class op $p1Applicative (BUILTIN) +Rule fired: Class op fmap (BUILTIN) +Rule fired: Class op $p1Monad (BUILTIN) Rule fired: Class op <*> (BUILTIN) Rule fired: Class op $p1Monad (BUILTIN) Rule fired: Class op $p1Applicative (BUILTIN) Rule fired: Class op fmap (BUILTIN) -Rule fired: Class op fmap (BUILTIN) Rule fired: Class op $p1Monad (BUILTIN) Rule fired: Class op <*> (BUILTIN) Rule fired: Class op $p1Monad (BUILTIN) Rule fired: Class op $p1Applicative (BUILTIN) Rule fired: Class op fmap (BUILTIN) Rule fired: Class op >>= (BUILTIN) -Rule fired: Class op fmap (BUILTIN) Rule fired: SPEC go @(StateT (Sum Int) Identity) (Main) Rule fired: Class op $p1Monad (BUILTIN) Rule fired: Class op pure (BUILTIN) diff --git a/testsuite/tests/simplCore/should_compile/Makefile b/testsuite/tests/simplCore/should_compile/Makefile index 396c375110..bc96b8f124 100644 --- a/testsuite/tests/simplCore/should_compile/Makefile +++ b/testsuite/tests/simplCore/should_compile/Makefile @@ -2,6 +2,11 @@ TOP=../../.. include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk +T17966: + $(RM) -f T17966.o T17966.hi + - '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-spec T17966.hs 2> /dev/null | grep 'SPEC' + # Expecting a SPEC rule for $cm + T17409: $(RM) -f T17409.o T17409.hi - '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -dverbose-core2core -dsuppress-uniques T17409.hs 2> /dev/null | grep '\<id\>' diff --git a/testsuite/tests/simplCore/should_compile/T17810.hs b/testsuite/tests/simplCore/should_compile/T17810.hs new file mode 100644 index 0000000000..6e13d9211c --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T17810.hs @@ -0,0 +1,7 @@ +module T17801 where + +import Control.Monad.Except +import T17810a + +f :: ExceptT e (TCMT IO) () +f = liftReduce diff --git a/testsuite/tests/simplCore/should_compile/T17810a.hs b/testsuite/tests/simplCore/should_compile/T17810a.hs new file mode 100644 index 0000000000..6f3cf88246 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T17810a.hs @@ -0,0 +1,27 @@ +module T17810a where + +import Control.Monad.Except + +class Monad m => ReadTCState m where + locallyTCState :: m () + liftReduce :: m () + +instance ReadTCState m => ReadTCState (ExceptT err m) where + locallyTCState = undefined + liftReduce = lift liftReduce + +instance MonadIO m => ReadTCState (TCMT m) where + locallyTCState = (undefined <$> liftReduce) <* TCM (\_ -> return ()) + liftReduce = undefined + +newtype TCMT m a = TCM { unTCM :: () -> m a } + +instance MonadIO m => Functor (TCMT m) where + fmap f (TCM m) = TCM $ \r -> liftM f (m r ) + +instance MonadIO m => Applicative (TCMT m) where + pure x = TCM (\_ -> return x) + (<*>) (TCM mf) (TCM m) = TCM $ \r -> ap (mf r) (m r) + +instance MonadIO m => Monad (TCMT m) where + (>>=) (TCM m) k = TCM $ \r -> m r >>= \x -> unTCM (k x) r diff --git a/testsuite/tests/simplCore/should_compile/T17930.hs b/testsuite/tests/simplCore/should_compile/T17930.hs new file mode 100644 index 0000000000..07a186840a --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T17930.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ImplicitParams #-} +module T17930 where + +foo :: (?b :: Bool, Show a) => a -> String +foo x | ?b = show x ++ "!" + | otherwise = show x ++ "." +{-# INLINABLE[0] foo #-} + +str :: String +str = let ?b = True in foo "Hello" diff --git a/testsuite/tests/simplCore/should_compile/T17930.stderr b/testsuite/tests/simplCore/should_compile/T17930.stderr new file mode 100644 index 0000000000..7b24d169f2 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T17930.stderr @@ -0,0 +1,2 @@ +$sfoo :: (?b::Bool) => [Char] -> [Char] +$sfoo diff --git a/testsuite/tests/simplCore/should_compile/T17966.hs b/testsuite/tests/simplCore/should_compile/T17966.hs new file mode 100644 index 0000000000..ca7803ea0b --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T17966.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +-- The issue here is whether $cm gets a specialiation +-- See #17966 + +module T17966 where + +class C a b where + m :: Show c => a -> b -> c -> String + +instance Show b => C Bool b where + m a b c = show a ++ show b ++ show c + {-# INLINABLE [0] m #-} + +f :: (C a b, Show c) => a -> b -> c -> String +f a b c = m a b c ++ "!" +{-# INLINABLE [0] f #-} + +x :: String +x = f True () (Just 42) diff --git a/testsuite/tests/simplCore/should_compile/T17966.stdout b/testsuite/tests/simplCore/should_compile/T17966.stdout new file mode 100644 index 0000000000..b324259b4a --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T17966.stdout @@ -0,0 +1,4 @@ + RULES: "SPEC $cm @()" [0] + RULES: "SPEC f @Bool @() @(Maybe Integer)" [0] +"SPEC/T17966 $fShowMaybe_$cshowList @Integer" +"SPEC/T17966 $fShowMaybe @Integer" diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index ed89a35690..b3262b8d19 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -319,3 +319,10 @@ test('T17787', [ grep_errmsg(r'foo') ], compile, ['-ddump-simpl -dsuppress-uniq test('T17901', normal, makefile_test, ['T17901']) +test('T17930', [ grep_errmsg(r'^\$sfoo') ], compile, ['-O -ddump-spec -dsuppress-uniques -dsuppress-idinfo']) +test('spec004', [ grep_errmsg(r'\$sfoo') ], compile, ['-O -ddump-spec -dsuppress-uniques']) +test('T17966', + normal, + makefile_test, ['T17966']) +# NB: T17810: -fspecialise-aggressively +test('T17810', normal, multimod_compile, ['T17810', '-fspecialise-aggressively -dcore-lint -O -v0']) diff --git a/testsuite/tests/simplCore/should_compile/spec004.hs b/testsuite/tests/simplCore/should_compile/spec004.hs new file mode 100644 index 0000000000..29b85c9f5b --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/spec004.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE RankNTypes #-} + +-- Dead arguments should be dropped in specialisations. See !2913. + +module ShouldCompile where + +foo :: () -> Show a => a -> String +foo _x y = show y ++ "!" +{-# NOINLINE[0] foo #-} + +bar :: String +bar = foo () (42 :: Int) diff --git a/testsuite/tests/simplCore/should_compile/spec004.stderr b/testsuite/tests/simplCore/should_compile/spec004.stderr new file mode 100644 index 0000000000..8d53785b68 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/spec004.stderr @@ -0,0 +1,84 @@ + +==================== Specialise ==================== +Result size of Specialise + = {terms: 53, types: 46, coercions: 0, joins: 0/0} + +-- RHS size: {terms: 14, types: 12, coercions: 0, joins: 0/0} +$sfoo [InlPrag=NOINLINE[0]] :: Int -> [Char] +[LclId] +$sfoo + = \ (y :: Int) -> + GHC.Base.build + @Char + (\ (@b) (c [OS=OneShot] :: Char -> b -> b) (n [OS=OneShot] :: b) -> + GHC.Base.foldr + @Char + @b + c + (GHC.CString.unpackFoldrCString# @b "!"# c n) + (show @Int GHC.Show.$fShowInt y)) + +-- RHS size: {terms: 17, types: 17, coercions: 0, joins: 0/0} +foo [InlPrag=NOINLINE[0]] :: forall a. () -> Show a => a -> String +[LclIdX, + Arity=3, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 30 0] 150 40}, + RULES: "SPEC foo @Int" [0] + forall (dk :: ()) ($dShow :: Show Int). foo @Int dk $dShow = $sfoo] +foo + = \ (@a) _ [Occ=Dead] ($dShow :: Show a) (y :: a) -> + GHC.Base.build + @Char + (\ (@b) (c [OS=OneShot] :: Char -> b -> b) (n [OS=OneShot] :: b) -> + GHC.Base.foldr + @Char + @b + c + (GHC.CString.unpackFoldrCString# @b "!"# c n) + (show @a $dShow y)) + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$trModule :: GHC.Prim.Addr# +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +$trModule = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$trModule :: GHC.Types.TrName +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +$trModule = GHC.Types.TrNameS $trModule + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$trModule :: GHC.Prim.Addr# +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 50 0}] +$trModule = "ShouldCompile"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$trModule :: GHC.Types.TrName +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +$trModule = GHC.Types.TrNameS $trModule + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +ShouldCompile.$trModule :: GHC.Types.Module +[LclIdX, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] +ShouldCompile.$trModule = GHC.Types.Module $trModule $trModule + +-- RHS size: {terms: 5, types: 1, coercions: 0, joins: 0/0} +bar :: String +[LclIdX, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False, + WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 50 0}] +bar = foo @Int GHC.Tuple.() GHC.Show.$fShowInt (GHC.Types.I# 42#) + + + |