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.

6 files changed, 115 insertions, 1 deletions

diff --git a/libraries/base/GHC/StaticPtr.hs b/libraries/base/GHC/StaticPtr.hs
new file mode 100644
index 0000000000..e7277ddbb4
--- /dev/null
+++ b/libraries/base/GHC/StaticPtr.hs
@@ -0,0 +1,107 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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 indicate
+-- package, module and name of a value. This information could be used to locate
+-- the value in different processes.
+--
+-- Currently, the main use case for references is the StaticPointers language
+-- extension.
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP                       #-}
+{-# LANGUAGE DeriveDataTypeable        #-}
+{-# LANGUAGE ForeignFunctionInterface  #-}
+{-# LANGUAGE MagicHash                 #-}
+{-# LANGUAGE UnboxedTuples             #-}
+{-# LANGUAGE ExistentialQuantification #-}
+module GHC.StaticPtr
+  ( StaticPtr
+  , staticName
+  , StaticName(..)
+  , DynStaticPtr(..)
+  , SptEntry
+  , deRefStaticPtr
+  , encodeStaticPtr
+  , decodeStaticPtr
+  ) where
+
+import Data.Typeable    (Typeable)
+import Data.Char
+import Foreign.C.String ( withCString, CString )
+import Foreign.Marshal  ( withArray )
+import Foreign.Ptr      ( castPtr )
+import GHC.Exts         ( addrToAny# )
+import GHC.Ptr          ( Ptr(..), nullPtr )
+import GHC.Fingerprint  ( Fingerprint(..), fingerprintString )
+import Numeric
+import System.Info      ( os )
+import System.IO.Unsafe ( unsafePerformIO )
+import Unsafe.Coerce    ( unsafeCoerce )
+
+
+-- | A reference to a top-level value of type 'a'.
+data StaticPtr a = StaticPtr StaticName a
+  deriving (Read, Show, Typeable)
+
+staticName :: StaticPtr a -> StaticName
+staticName (StaticPtr n _) = n
+
+-- | Identification of top-level values
+--
+-- > StaticName package_id module_name value_name
+--
+data StaticName = StaticName String String String
+  deriving (Read, Show, Typeable)
+
+-- | Entries of the static pointer table.
+data SptEntry = forall a . SptEntry StaticName a
+
+-- | Dynamic static pointer.
+data DynStaticPtr = forall a . DSP (StaticPtr a)
+
+-- | Encodes static pointer in the form that can be later serialized.
+encodeStaticPtr :: StaticPtr a -> Fingerprint
+encodeStaticPtr = fingerprintStaticName . staticName
+
+-- | Decodes an encoded pointer. It looks up a static pointer in
+-- entry in the static pointer table.
+decodeStaticPtr :: Fingerprint -> Maybe DynStaticPtr
+decodeStaticPtr key = unsafePerformIO $
+   fmap (fmap (\(SptEntry s v) -> DSP $ StaticPtr s v)) (sptLookup key)
+
+-- | Dereferences a static pointer.
+deRefStaticPtr :: StaticPtr a -> a
+deRefStaticPtr p@(StaticPtr s v) = v
+
+fingerprintStaticName :: StaticName -> Fingerprint
+fingerprintStaticName (StaticName pkg m valsym) =
+    fingerprintString $ concat [pkg, ":", m, ".", valsym]
+
+sptLookup :: Fingerprint -> IO (Maybe SptEntry)
+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)
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index c3f4d28a1e..b857db4853 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -252,6 +252,7 @@ Library
         GHC.Ptr
         GHC.Read
         GHC.Real
+        GHC.StaticPtr
         GHC.ST
         GHC.STRef
         GHC.Show
diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs
index e038a3ba6b..ac277b78fa 100644
--- a/libraries/template-haskell/Language/Haskell/TH.hs
+++ b/libraries/template-haskell/Language/Haskell/TH.hs
@@ -90,7 +90,7 @@ module Language.Haskell.TH(
         normalB, guardedB, normalG, normalGE, patG, patGE, match, clause,
 
     -- *** Expressions
-        dyn, global, varE, conE, litE, appE, uInfixE, parensE,
+        dyn, global, varE, conE, litE, appE, uInfixE, parensE, staticE,
         infixE, infixApp, sectionL, sectionR,
         lamE, lam1E, lamCaseE, tupE, condE, multiIfE, letE, caseE, appsE,
         listE, sigE, recConE, recUpdE, stringE, fieldExp,
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index efe597275b..97a5a9efe5 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -296,6 +296,9 @@ stringE = litE . stringL
 fieldExp :: Name -> ExpQ -> Q (Name, Exp)
 fieldExp s e = do { e' <- e; return (s,e') }
 
+staticE :: ExpQ -> ExpQ
+staticE =  fmap StaticE
+
 -- ** 'arithSeqE' Shortcuts
 fromE :: ExpQ -> ExpQ
 fromE x = do { a <- x; return (ArithSeqE (FromR a)) }
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 5f3a0c6c9b..0f828eb98b 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -172,6 +172,8 @@ pprExp _ (ListE es) = brackets $ sep $ punctuate comma $ map ppr es
 pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> text "::" <+> ppr t
 pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs)
 pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)
+pprExp i (StaticE e) = parensIf (i >= appPrec) $
+                         text "static"<+> pprExp appPrec e
 
 pprFields :: [(Name,Exp)] -> Doc
 pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e)
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index ddbe3a98e2..0c75fb99b8 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1145,6 +1145,7 @@ data Exp
   | SigE Exp Type                      -- ^ @{ e :: t }@
   | RecConE Name [FieldExp]            -- ^ @{ T { x = y, z = w } }@
   | RecUpdE Exp [FieldExp]             -- ^ @{ (f x) { z = w } }@
+  | StaticE Exp                        -- ^ @{ static e }@
   deriving( Show, Eq, Data, Typeable, Generic )
 
 type FieldExp = (Name,Exp)