diff options
Diffstat (limited to 'testsuite/tests')
32 files changed, 275 insertions, 2 deletions
diff --git a/testsuite/tests/codeGen/should_run/CgStaticPointers.hs b/testsuite/tests/codeGen/should_run/CgStaticPointers.hs new file mode 100644 index 0000000000..bc11f4b076 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/CgStaticPointers.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StaticPointers #-} + +-- |A test to load symbols produced by the static form. +-- +-- First we have this program load itself using the GHC API. +-- Then we look for the symbols that the static form should have +-- exposed and use the values found at the symbol addresses. +-- +module Main(main) where + +import Data.Typeable +import GHC.StaticPtr + +main :: IO () +main = do + -- For some reason, removing the type signature below causes @g@ to appear + -- in the desugarer with a coercion like: + -- main@main:Main.g{v r20J} |> (Sub cobox_a36d{v}[lid]) + print $ deRefStaticPtr (static g :: StaticPtr String) + -- For some reason, removing the type signature below causes an assertion + -- failure in the compiler: + -- + -- ASSERT failed! file compiler/typecheck/TcType.lhs line 645 + print $ deRefStaticPtr (static t_field :: StaticPtr (T Char -> Char)) $ T 'b' + +g :: String +g = "found" + +data T a = T { t_field :: a } + deriving Typeable diff --git a/testsuite/tests/codeGen/should_run/CgStaticPointers.stdout b/testsuite/tests/codeGen/should_run/CgStaticPointers.stdout new file mode 100644 index 0000000000..f867935850 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/CgStaticPointers.stdout @@ -0,0 +1,2 @@ +"found" +'b' diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T index 03106d4791..ae6874900e 100644 --- a/testsuite/tests/codeGen/should_run/all.T +++ b/testsuite/tests/codeGen/should_run/all.T @@ -114,6 +114,9 @@ test('T8103', only_ways(['normal']), compile_and_run, ['']) test('T7953', reqlib('random'), compile_and_run, ['']) test('T8256', reqlib('vector'), compile_and_run, ['']) test('T6084',normal, compile_and_run, ['-O2']) +test('CgStaticPointers', + [ when(compiler_lt('ghc', '7.9'), skip) ], + compile_and_run, ['']) test('StaticArraySize', normal, compile_and_run, ['-O2']) test('StaticByteArraySize', normal, compile_and_run, ['-O2']) test('CopySmallArray', normal, compile_and_run, ['']) diff --git a/testsuite/tests/deSugar/should_run/DsStaticPointers.hs b/testsuite/tests/deSugar/should_run/DsStaticPointers.hs new file mode 100644 index 0000000000..7bc0265a41 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/DsStaticPointers.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StaticPointers #-} + +import Data.Typeable +import GHC.StaticPtr + +main = putStr $ unlines $ map show names + where + names = + [ -- unStaticPtr $ static g + staticName $ (static id :: StaticPtr (Int -> Int)) + -- , unStaticPtr $ static (&&) + , staticName $ (static t_field :: StaticPtr (T Int -> Int)) + ] + +g :: Int -> Int +g = id + +data T a = T { t_field :: a } + deriving Typeable diff --git a/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout b/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout new file mode 100644 index 0000000000..c362ee455d --- /dev/null +++ b/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout @@ -0,0 +1,2 @@ +StaticName "main" "Main" "sptEntry:0" +StaticName "main" "Main" "sptEntry:1" diff --git a/testsuite/tests/deSugar/should_run/all.T b/testsuite/tests/deSugar/should_run/all.T index 233f6485d9..9e3d1ea894 100644 --- a/testsuite/tests/deSugar/should_run/all.T +++ b/testsuite/tests/deSugar/should_run/all.T @@ -40,4 +40,6 @@ test('mc08', normal, compile_and_run, ['']) test('T5742', normal, compile_and_run, ['']) test('DsLambdaCase', when(compiler_lt('ghc', '7.5'), skip), compile_and_run, ['']) test('DsMultiWayIf', when(compiler_lt('ghc', '7.5'), skip), compile_and_run, ['']) +test('DsStaticPointers', + when(compiler_lt('ghc', '7.9'), skip), compile_and_run, ['']) test('T8952', normal, compile_and_run, ['']) diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index 40ddb4b66b..51e49053a6 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -34,7 +34,8 @@ expectedGhcOnlyExtensions = ["RelaxedLayout", "AlternativeLayoutRule", "AlternativeLayoutRuleTransitional", "JavaScriptFFI", - "PatternSynonyms"] + "PatternSynonyms", + "StaticValues"] expectedCabalOnlyExtensions :: [String] expectedCabalOnlyExtensions = ["Generics", diff --git a/testsuite/tests/parser/should_compile/RdrNoStaticPointers01.hs b/testsuite/tests/parser/should_compile/RdrNoStaticPointers01.hs new file mode 100644 index 0000000000..b6f088527f --- /dev/null +++ b/testsuite/tests/parser/should_compile/RdrNoStaticPointers01.hs @@ -0,0 +1,7 @@ +-- Tests that when the StaticPointers extension is not enabled +-- the static identifier can be used as a regular Haskell +-- identifier. +module RdrNoStaticPointers01 where + +f :: Int -> Int +f static = static diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T index e9cc99e959..13acedf014 100644 --- a/testsuite/tests/parser/should_compile/all.T +++ b/testsuite/tests/parser/should_compile/all.T @@ -96,4 +96,5 @@ test('T5243', extra_clean(['T5243A.hi', 'T5243A.o']), multimod_compile, ['T5243','']) test('T7118', normal, compile, ['']) test('T7776', normal, compile, ['']) -test('T5682', normal, compile, [''])
\ No newline at end of file +test('RdrNoStaticPointers01', when(compiler_lt('ghc', '7.9'), skip), compile, ['']) +test('T5682', normal, compile, ['']) diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail01.hs b/testsuite/tests/rename/should_fail/RnStaticPointersFail01.hs new file mode 100644 index 0000000000..18631a2dc5 --- /dev/null +++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail01.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE StaticPointers #-} + +module RnStaticPointersFail01 where + +f x = static x diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr b/testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr new file mode 100644 index 0000000000..b7ff89c886 --- /dev/null +++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr @@ -0,0 +1,6 @@ + +RnStaticPointersFail01.hs:5:7: + Only identifiers of top-level bindings can appear in the body of the static form: + static x + but the following identifiers were found instead: + x diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail02.hs b/testsuite/tests/rename/should_fail/RnStaticPointersFail02.hs new file mode 100644 index 0000000000..599cf53076 --- /dev/null +++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail02.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE StaticPointers #-} + +module RnStaticPointersFail02 where + +f = static T + +data T = TDataCons diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail02.stderr b/testsuite/tests/rename/should_fail/RnStaticPointersFail02.stderr new file mode 100644 index 0000000000..6524702276 --- /dev/null +++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail02.stderr @@ -0,0 +1,8 @@ + +RnStaticPointersFail02.hs:5:5: + Only identifiers of top-level bindings can appear in the body of the static form: + static T + but the following identifiers were found instead: + T + +RnStaticPointersFail02.hs:5:12: Not in scope: data constructor ‘T’ diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs new file mode 100644 index 0000000000..7f777727d3 --- /dev/null +++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE StaticPointers #-} + +module RnStaticPointersFail03 where + +f x = static x diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr new file mode 100644 index 0000000000..771cdd2921 --- /dev/null +++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr @@ -0,0 +1,6 @@ + +RnStaticPointersFail03.hs:5:7: + Only identifiers of top-level bindings can appear in the body of the static form: + static x + but the following identifiers were found instead: + x diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T index f2664dc2bf..f6ace100e5 100644 --- a/testsuite/tests/rename/should_fail/all.T +++ b/testsuite/tests/rename/should_fail/all.T @@ -111,6 +111,12 @@ test('T7906', normal, compile_fail, ['']) test('T7937', normal, compile_fail, ['']) test('T7943', normal, compile_fail, ['']) test('T8448', normal, compile_fail, ['']) +test('RnStaticPointersFail01', + when(compiler_lt('ghc', '7.9'), skip), compile_fail, ['']) +test('RnStaticPointersFail02', + when(compiler_lt('ghc', '7.9'), skip), compile_fail, ['']) +test('RnStaticPointersFail03', + when(compiler_lt('ghc', '7.9'), skip), compile_fail, ['']) test('T9006', extra_clean(['T9006a.hi', 'T9006a.o']), multimod_compile_fail, ['T9006', '-v0']) diff --git a/testsuite/tests/rts/GcStaticPointers.hs b/testsuite/tests/rts/GcStaticPointers.hs new file mode 100644 index 0000000000..e68f8b22c3 --- /dev/null +++ b/testsuite/tests/rts/GcStaticPointers.hs @@ -0,0 +1,33 @@ +-- A test to show that -XStaticPointers keeps generated CAFs alive. +{-# LANGUAGE StaticPointers #-} +module Main where + +import GHC.StaticPtr + +import Control.Concurrent +import Data.Maybe (fromJust) +import GHC.Fingerprint +import System.Mem +import System.Mem.Weak +import Unsafe.Coerce (unsafeCoerce) + +nats :: [Integer] +nats = [0 .. ] + +-- Just a StaticPtr to some CAF so that we can deRef it. +nats_fp :: Fingerprint +nats_fp = encodeStaticPtr (static nats :: StaticPtr [Integer]) + +main = do + let z = nats !! 400 + print z + performGC + addFinalizer z (putStrLn "finalizer z") + print z + performGC + threadDelay 1000000 + case decodeStaticPtr nats_fp of + Just (DSP p) -> print (deRefStaticPtr (unsafeCoerce p) !! 800 :: Integer) + -- Uncommenting the next line keeps primes alive and would prevent a segfault + -- if nats were garbage collected. + -- print (nats !! 900) diff --git a/testsuite/tests/rts/GcStaticPointers.stdout b/testsuite/tests/rts/GcStaticPointers.stdout new file mode 100644 index 0000000000..f3c61da20a --- /dev/null +++ b/testsuite/tests/rts/GcStaticPointers.stdout @@ -0,0 +1,3 @@ +400 +400 +800 diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T index 6d0859432b..cbd5d095b5 100644 --- a/testsuite/tests/rts/all.T +++ b/testsuite/tests/rts/all.T @@ -242,6 +242,10 @@ test('rdynamic', [ unless(opsys('linux') or opsys('mingw32'), skip) ], compile_and_run, ['-rdynamic -package ghc']) +test('GcStaticPointers', + [ when(compiler_lt('ghc', '7.9'), skip) ], + compile_and_run, ['']) + # 251 = RTS exit code for "out of memory" test('overflow1', [ exit_code(251) ], compile_and_run, ['']) test('overflow2', [ exit_code(251) ], compile_and_run, ['']) diff --git a/testsuite/tests/th/TH_StaticPointers.hs b/testsuite/tests/th/TH_StaticPointers.hs new file mode 100644 index 0000000000..f8045426cc --- /dev/null +++ b/testsuite/tests/th/TH_StaticPointers.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StaticPointers #-} + +-- |A test to load symbols produced by the static form. +-- +-- First we have this program load itself using the GHC API. +-- Then we look for the symbols that the static form should have +-- exposed and use the values found at the symbol addresses. +-- +-- Note that we lookup for 'g' in symbol tables which does not appear +-- in the export list of Main. +-- +module Main(main) where + +import GHC.StaticPtr + +main = print $ deRefStaticPtr $([| static g :: StaticPtr String |]) + +g = "found" diff --git a/testsuite/tests/th/TH_StaticPointers.stdout b/testsuite/tests/th/TH_StaticPointers.stdout new file mode 100644 index 0000000000..e4c4f00788 --- /dev/null +++ b/testsuite/tests/th/TH_StaticPointers.stdout @@ -0,0 +1 @@ +"found" diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 90efcbd427..0dc352bdcd 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -319,6 +319,9 @@ test('T8577', ['T8577', '-v0 ' + config.ghc_th_way_flags]) test('T8633', normal, compile_and_run, ['']) test('T8625', normal, ghci_script, ['T8625.script']) +test('TH_StaticPointers', + [ when(compiler_lt('ghc', '7.9'), skip) ], + compile_and_run, ['']) test('T8759', normal, compile_fail, ['-v0']) test('T8759a', normal, compile_fail, ['-v0']) test('T7021', diff --git a/testsuite/tests/typecheck/should_compile/TcStaticPointers01.hs b/testsuite/tests/typecheck/should_compile/TcStaticPointers01.hs new file mode 100644 index 0000000000..0f1421ee6b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/TcStaticPointers01.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE StaticPointers #-} + +module StaticPointers01 where + +import GHC.StaticPtr + +f0 :: StaticPtr (Int -> Int) +f0 = static g + +f1 :: StaticPtr (Bool -> Bool -> Bool) +f1 = static (&&) + +g :: Int -> Int +g = id diff --git a/testsuite/tests/typecheck/should_compile/TcStaticPointers02.hs b/testsuite/tests/typecheck/should_compile/TcStaticPointers02.hs new file mode 100644 index 0000000000..3a7461e5ba --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/TcStaticPointers02.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StaticPointers #-} + +module StaticPointers02 where + +import GHC.StaticPtr +import Data.Typeable + +f2 :: Typeable a => StaticPtr (a -> a) +f2 = static id + +f4 :: Typeable a => StaticPtr (T a -> a) +f4 = static t_field + +g :: Int -> Int +g = id + +data T a = T { t_field :: a } + deriving Typeable diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index ef830d14d5..b9d1d4c725 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -416,6 +416,8 @@ test('T8474', normal, compile, ['']) test('T8563', normal, compile, ['']) test('T8565', normal, compile, ['']) test('T8644', normal, compile, ['']) +test('TcStaticPointers01', when(compiler_lt('ghc', '7.9'), skip), compile, ['']) +test('TcStaticPointers02', when(compiler_lt('ghc', '7.9'), skip), compile, ['']) test('T8762', normal, compile, ['']) test('MutRec', normal, compile, ['']) test('T8856', normal, compile, ['']) diff --git a/testsuite/tests/typecheck/should_fail/TcStaticPointersFail01.hs b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail01.hs new file mode 100644 index 0000000000..7221b7369b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail01.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE StaticPointers #-} + +module StaticPointersFail01 where + +import GHC.StaticPtr + +f0 :: StaticPtr Int +f0 = static g + +g :: Int -> Int +g = id diff --git a/testsuite/tests/typecheck/should_fail/TcStaticPointersFail01.stderr b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail01.stderr new file mode 100644 index 0000000000..e41ec7443d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail01.stderr @@ -0,0 +1,6 @@ + +TcStaticPointersFail01.hs:8:13: + Couldn't match expected type ‘Int’ with actual type ‘Int -> Int’ + Probable cause: ‘g’ is applied to too few arguments + In the body of a static form: g + In the expression: static g diff --git a/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.hs b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.hs new file mode 100644 index 0000000000..3b4d0ff661 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE StaticPointers #-} +{-# LANGUAGE ImpredicativeTypes #-} + +module StaticPointersFail02 where + +import GHC.StaticPtr + +f1 :: StaticPtr ((forall a . a -> a) -> b) +f1 = static (undefined :: (forall a . a -> a) -> b) + +f2 :: StaticPtr (Monad m => a -> m a) +f2 = static return diff --git a/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr new file mode 100644 index 0000000000..5b6f56ad16 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr @@ -0,0 +1,13 @@ + +TcStaticPointersFail02.hs:9:6: + No instance for (Data.Typeable.Internal.Typeable b) + arising from a static form + In the expression: static (undefined :: (forall a. a -> a) -> b) + In an equation for ‘f1’: + f1 = static (undefined :: (forall a. a -> a) -> b) + +TcStaticPointersFail02.hs:12:6: + No instance for (Data.Typeable.Internal.Typeable Monad) + arising from a static form + In the expression: static return + In an equation for ‘f2’: f2 = static return diff --git a/testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.hs b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.hs new file mode 100644 index 0000000000..58e06ee1d8 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE StaticPointers #-} + +module StaticPointersFail03 where + +import GHC.StaticPtr +import Data.Typeable + +f1 :: (Typeable a, Typeable m, Monad m) => a -> m a +f1 = deRefStaticPtr (static return) diff --git a/testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.stderr b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.stderr new file mode 100644 index 0000000000..025744a285 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.stderr @@ -0,0 +1,6 @@ + +TcStaticPointersFail03.hs:9:29: + Illegal polymorphic or qualified type: Monad m => a -> m a + In the body of a static form: return + In the first argument of ‘deRefStaticPtr’, namely ‘(static return)’ + In the expression: deRefStaticPtr (static return) diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index 2b128dc004..d899e9edb1 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -330,6 +330,12 @@ test('ContextStack2', normal, compile_fail, ['-ftype-function-depth=10']) test('T8570', extra_clean(['T85570a.o', 'T8570a.hi','T85570b.o', 'T8570b.hi']), multimod_compile_fail, ['T8570', '-v0']) test('T8603', normal, compile_fail, ['']) +test('TcStaticPointersFail01', + when(compiler_lt('ghc', '7.9'), skip), compile_fail, ['']) +test('TcStaticPointersFail02', + when(compiler_lt('ghc', '7.9'), skip), compile_fail, ['']) +test('TcStaticPointersFail03', + when(compiler_lt('ghc', '7.9'), skip), compile_fail, ['']) test('T8806', normal, compile_fail, ['']) test('T8912', normal, compile_fail, ['']) test('T9033', normal, compile_fail, ['']) |