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

1 files changed, 122 insertions, 0 deletions

diff --git a/libraries/base/GHC/StaticPtr.hs b/libraries/base/GHC/StaticPtr.hs
new file mode 100644
index 0000000000..b92b843989
--- /dev/null
+++ b/libraries/base/GHC/StaticPtr.hs
@@ -0,0 +1,122 @@
+{-# LANGUAGE DeriveDataTypeable        #-}
+{-# LANGUAGE MagicHash                 #-}
+{-# LANGUAGE UnboxedTuples             #-}
+{-# LANGUAGE ExistentialQuantification #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.StaticPtr
+-- Copyright   :  (C) 2014 I/O Tweag
+-- License     :  see libraries/base/LICENSE
+--
+-- Maintainer  :  cvs-ghc@haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Symbolic references to values.
+--
+-- References to values are usually implemented with memory addresses, and this
+-- is practical when communicating values between the different pieces of a
+-- single process.
+--
+-- When values are communicated across different processes running in possibly
+-- different machines, though, addresses are no longer useful since each
+-- process may use different addresses to store a given value.
+--
+-- To solve such concern, the references provided by this module offer a key
+-- that can be used to locate the values on each process. Each process maintains
+-- a global and inmutable table of references which can be looked up with a
+-- given key. This table is known as the Static Pointer Table. The reference can
+-- then be dereferenced to obtain the value.
+--
+-----------------------------------------------------------------------------
+
+module GHC.StaticPtr
+  ( StaticPtr
+  , deRefStaticPtr
+  , StaticKey
+  , staticKey
+  , unsafeLookupStaticPtr
+  , StaticPtrInfo(..)
+  , staticPtrInfo
+  , staticPtrKeys
+  ) where
+
+import Data.Typeable       (Typeable)
+import Foreign.C.Types     (CInt(..))
+import Foreign.Marshal     (allocaArray, peekArray, withArray)
+import Foreign.Ptr         (castPtr)
+import GHC.Exts            (addrToAny#)
+import GHC.Ptr             (Ptr(..), nullPtr)
+import GHC.Fingerprint     (Fingerprint(..))
+import System.IO.Unsafe    (unsafePerformIO)
+
+
+-- | A reference to a value of type 'a'.
+data StaticPtr a = StaticPtr StaticKey StaticPtrInfo a
+  deriving Typeable
+
+-- | Dereferences a static pointer.
+deRefStaticPtr :: StaticPtr a -> a
+deRefStaticPtr (StaticPtr _ _ v) = v
+
+-- | A key for `StaticPtrs` that can be serialized and used with
+-- 'unsafeLookupStaticPtr'.
+type StaticKey = Fingerprint
+
+-- | The 'StaticKey' that can be used to look up the given 'StaticPtr'.
+staticKey :: StaticPtr a -> StaticKey
+staticKey (StaticPtr k _ _) = k
+
+-- | Looks up a 'StaticPtr' by its 'StaticKey'.
+--
+-- If the 'StaticPtr' is not found returns @Nothing@.
+--
+-- This function is unsafe because the program behavior is undefined if the type
+-- of the returned 'StaticPtr' does not match the expected one.
+--
+unsafeLookupStaticPtr :: StaticKey -> Maybe (StaticPtr a)
+unsafeLookupStaticPtr k = unsafePerformIO $ sptLookup k
+
+-- | Miscelaneous information available for debugging purposes.
+data StaticPtrInfo = StaticPtrInfo
+    { -- | PackageId of the package where the static pointer is defined
+      spInfoPackageId  :: String
+      -- | Name of the module where the static pointer is defined
+    , spInfoModuleName :: String
+      -- | An internal name that is distinct for every static pointer defined in
+      -- a given module.
+    , spInfoName       :: String
+      -- | Source location of the definition of the static pointer as a
+      -- @(Line, Column)@ pair.
+    , spIntoSrcLoc     :: (Int, Int)
+    }
+  deriving (Show, Typeable)
+
+-- | 'StaticPtrInfo' of the given 'StaticPtr'.
+staticPtrInfo :: StaticPtr a -> StaticPtrInfo
+staticPtrInfo (StaticPtr _ n _) = n
+
+-- | Like 'unsafeLookupStaticPtr' but evaluates in 'IO'.
+sptLookup :: StaticKey -> IO (Maybe (StaticPtr a))
+sptLookup (Fingerprint w1 w2) = do
+    ptr@(Ptr addr) <- withArray [w1,w2] (hs_spt_lookup . castPtr)
+    if (ptr == nullPtr)
+    then return Nothing
+    else case addrToAny# addr of
+           (# spe #) -> return (Just spe)
+
+foreign import ccall unsafe hs_spt_lookup :: Ptr () -> IO (Ptr a)
+
+-- | A list of all known keys.
+staticPtrKeys :: [StaticKey]
+staticPtrKeys = unsafePerformIO $ do
+    keyCount <- hs_spt_key_count
+    allocaArray (fromIntegral keyCount) $ \p -> do
+      count <- hs_spt_keys p keyCount
+      peekArray (fromIntegral count) p >>=
+        mapM (\pa -> peekArray 2 pa >>= \[w1, w2] -> return $ Fingerprint w1 w2)
+{-# NOINLINE staticPtrKeys #-}
+
+foreign import ccall unsafe hs_spt_key_count :: IO CInt
+
+foreign import ccall unsafe hs_spt_keys :: Ptr a -> CInt -> IO CInt