summaryrefslogtreecommitdiff
path: root/testsuite
diff options
context:
space:
mode:
authorFacundo Domínguez <facundo.dominguez@tweag.io>2014-01-29 12:43:03 -0200
committerFacundo Domínguez <facundo.dominguez@tweag.io>2014-12-02 12:55:30 -0200
commit79c87c039c47be0baf7a6dd33ecf5434daa1501c (patch)
treed8d97a28d3989bf7848a5c3f8f6a4697de72fd5c /testsuite
parenta2c0a8dd15de2023e17078fa5f421ba581b3a5fa (diff)
downloadhaskell-wip/static-pointers.tar.gz
Implement -XStaticValues.wip/static-pointers
Contains contributions from Alexander Vershilov and Mathieu Boespflug. As proposed in [1], this extension introduces a new syntactic form `static e`, where `e :: a` can be any closed expression. The static form produces a value of type `StaticPtr a`, which works as a reference that programs can "dereference" to get the value of `e` back. References are like `Ptr`s, except that they are stable across invocations of a program. In essence the extension collects the arguments of the static form into a global static pointer table. The expressions can be looked up by a fingerprint computed from the package, the module and a fresh name given to the expression. For more details we refer to the users guide section contained in the patch. The extension is a contribution to the Cloud Haskell ecosystem (distributed-process and related), and thus has the potential to foster Haskell as a programming language for distributed systems. The immediate improvement brought by the extension is the elimination of remote tables from Cloud Haskell applications. Such applications contain table fragments spread throughout multiple modules and packages. Eliminating these fragments saves the programmer the burden required to construct and assemble the global remote table, a verbose and error-prone process, even with the help of Template Haskell, that moreover pollutes the export lists of all modules. [1] Jeff Epstein, Andrew P. Black, and Simon Peyton-Jones. Towards Haskell in the cloud. SIGPLAN Not., 46(12):118–129, September 2011. ISSN 0362-1340.
Diffstat (limited to 'testsuite')
-rw-r--r--testsuite/tests/codeGen/should_run/CgStaticPointers.hs31
-rw-r--r--testsuite/tests/codeGen/should_run/CgStaticPointers.stdout2
-rw-r--r--testsuite/tests/codeGen/should_run/all.T3
-rw-r--r--testsuite/tests/deSugar/should_run/DsStaticPointers.hs20
-rw-r--r--testsuite/tests/deSugar/should_run/DsStaticPointers.stdout2
-rw-r--r--testsuite/tests/deSugar/should_run/all.T2
-rw-r--r--testsuite/tests/driver/T4437.hs3
-rw-r--r--testsuite/tests/parser/should_compile/RdrNoStaticPointers01.hs7
-rw-r--r--testsuite/tests/parser/should_compile/all.T3
-rw-r--r--testsuite/tests/rename/should_fail/RnStaticPointersFail01.hs5
-rw-r--r--testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr6
-rw-r--r--testsuite/tests/rename/should_fail/RnStaticPointersFail02.hs7
-rw-r--r--testsuite/tests/rename/should_fail/RnStaticPointersFail02.stderr8
-rw-r--r--testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs5
-rw-r--r--testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr6
-rw-r--r--testsuite/tests/rename/should_fail/all.T6
-rw-r--r--testsuite/tests/rts/GcStaticPointers.hs33
-rw-r--r--testsuite/tests/rts/GcStaticPointers.stdout3
-rw-r--r--testsuite/tests/rts/all.T4
-rw-r--r--testsuite/tests/th/TH_StaticPointers.hs19
-rw-r--r--testsuite/tests/th/TH_StaticPointers.stdout1
-rw-r--r--testsuite/tests/th/all.T3
-rw-r--r--testsuite/tests/typecheck/should_compile/TcStaticPointers01.hs14
-rw-r--r--testsuite/tests/typecheck/should_compile/TcStaticPointers02.hs19
-rw-r--r--testsuite/tests/typecheck/should_compile/all.T2
-rw-r--r--testsuite/tests/typecheck/should_fail/TcStaticPointersFail01.hs11
-rw-r--r--testsuite/tests/typecheck/should_fail/TcStaticPointersFail01.stderr6
-rw-r--r--testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.hs12
-rw-r--r--testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr13
-rw-r--r--testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.hs9
-rw-r--r--testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.stderr6
-rw-r--r--testsuite/tests/typecheck/should_fail/all.T6
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, [''])