Implement -XStaticValues

Summary:
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.

The relevant wiki pages are [2, 3], which describe the motivation/ideas
and implementation plan respectively.

[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.
[2] https://ghc.haskell.org/trac/ghc/wiki/StaticPointers
[3] https://ghc.haskell.org/trac/ghc/wiki/StaticPointers/ImplementationPlan

Authored-by: Facundo Domínguez <facundo.dominguez@tweag.io>
Authored-by: Mathieu Boespflug <m@tweag.io>
Authored-by: Alexander Vershilov <alexander.vershilov@tweag.io>

Test Plan: `./validate`

Reviewers: hvr, simonmar, simonpj, austin

Reviewed By: simonpj, austin

Subscribers: qnikst, bgamari, mboes, carter, thomie, goldfire

Differential Revision: https://phabricator.haskell.org/D550

GHC Trac Issues: #7015

4 files changed, 69 insertions, 0 deletions

diff --git a/testsuite/tests/rts/GcStaticPointers.hs b/testsuite/tests/rts/GcStaticPointers.hs
new file mode 100644
index 0000000000..7c2fc2b354
--- /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 :: StaticKey
+nats_fp = staticKey (static nats :: StaticPtr [Integer])
+
+main = do
+  let z = nats !! 400
+  print z
+  performGC
+  addFinalizer z (putStrLn "finalizer z")
+  print z
+  performGC
+  threadDelay 1000000
+  let Just p = unsafeLookupStaticPtr nats_fp
+  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/ListStaticPointers.hs b/testsuite/tests/rts/ListStaticPointers.hs
new file mode 100644
index 0000000000..5ddb63613f
--- /dev/null
+++ b/testsuite/tests/rts/ListStaticPointers.hs
@@ -0,0 +1,26 @@
+-- A test to show that Static Pointers can be listed.
+{-# LANGUAGE StaticPointers #-}
+module Main where
+
+import Control.Monad (when)
+import Data.List ((\\))
+import GHC.StaticPtr
+import System.Exit
+
+main = when (not $ eqBags staticPtrKeys expected) $ do
+    print ("expected", expected)
+    print ("found", staticPtrKeys)
+    exitFailure
+  where
+
+    expected =
+      [ staticKey $  static (\x -> x :: Int)
+      , staticKey   (static return :: StaticPtr (Int -> IO Int))
+      , staticKey $  static g
+      ]
+
+    eqBags :: Eq a => [a] -> [a] -> Bool
+    eqBags xs ys = null (xs \\ ys) && null (ys \\ xs)
+
+g :: Int -> Int
+g = (+1)
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index 7162f4c667..b997a574fc 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -243,6 +243,13 @@ 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, [''])
+test('ListStaticPointers',
+     [ 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, [''])