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.

1 files changed, 85 insertions, 1 deletions

diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index f4dca9a0de..e7dd7df46c 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -1,4 +1,4 @@
-%
+, alpha%
 % (c) The GRASP Project, Glasgow University, 1994-1998
 %
 \section[TysWiredIn]{Wired-in knowledge about {\em non-primitive} types}
@@ -67,6 +67,12 @@ module TysWiredIn (
         parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon,
         parrTyCon_RDR, parrTyConName,
 
+        -- * StaticPtr
+        staticPtrTyCon, staticPtrTyConName,
+        staticPtrDataCon, staticNameDataCon,
+        staticSptEntryTy, staticSptEntryTyCon,
+        staticSptEntryTyConName, staticSptEntryDataCon,
+
         -- * Equality predicates
         eqTyCon_RDR, eqTyCon, eqTyConName, eqBoxDataCon,
         coercibleTyCon, coercibleDataCon, coercibleClass,
@@ -151,6 +157,8 @@ wiredInTyCons = [ unitTyCon     -- Not treated like other tuples, because
               , wordTyCon
               , listTyCon
               , parrTyCon
+              , staticPtrTyCon
+              , staticNameTyCon
               , eqTyCon
               , coercibleTyCon
               , typeNatKindCon
@@ -216,6 +224,24 @@ parrTyConName   = mkWiredInTyConName   BuiltInSyntax
 parrDataConName = mkWiredInDataConName UserSyntax
                     gHC_PARR' (fsLit "PArr") parrDataConKey parrDataCon
 
+staticPtrTyConName, staticPtrDataConName :: Name
+staticPtrTyConName   = mkWiredInTyConName UserSyntax
+    gHC_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey staticPtrTyCon
+staticPtrDataConName = mkWiredInDataConName UserSyntax
+    gHC_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey staticPtrDataCon
+
+staticNameTyConName, staticNameDataConName :: Name
+staticNameTyConName   = mkWiredInTyConName UserSyntax
+    gHC_STATICPTR (fsLit "StaticName") staticNameTyConKey staticNameTyCon
+staticNameDataConName = mkWiredInDataConName UserSyntax
+    gHC_STATICPTR (fsLit "StaticName") staticNameDataConKey staticNameDataCon
+
+staticSptEntryTyConName, staticSptEntryDataConName :: Name
+staticSptEntryTyConName = mkWiredInTyConName UserSyntax
+    gHC_STATICPTR (fsLit "SptEntry") staticSptEntryTyConKey staticSptEntryTyCon
+staticSptEntryDataConName = mkWiredInDataConName UserSyntax
+    gHC_STATICPTR (fsLit "SptEntry") staticSptEntryConKey staticNameDataCon
+
 boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR,
     intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR, eqTyCon_RDR :: RdrName
 boolTyCon_RDR   = nameRdrName boolTyConName
@@ -850,6 +876,64 @@ isPArrFakeCon      :: DataCon -> Bool
 isPArrFakeCon dcon  = dcon == parrFakeCon (dataConSourceArity dcon)
 \end{code}
 
+StaticPtr
+
+\begin{code}
+staticPtrTyCon :: TyCon
+staticPtrTyCon  =
+    pcNonRecDataTyCon staticPtrTyConName Nothing alpha_tyvar [staticPtrDataCon]
+
+staticPtrDataCon :: DataCon
+staticPtrDataCon  =
+    pcDataCon staticPtrDataConName alpha_tyvar [staticNameTy, alphaTy] staticPtrTyCon
+
+staticNameTy :: Type
+staticNameTy = mkTyConTy staticNameTyCon
+
+staticNameTyCon :: TyCon
+staticNameTyCon  =
+    pcNonRecDataTyCon staticNameTyConName Nothing [] [staticNameDataCon]
+
+staticNameDataCon :: DataCon
+staticNameDataCon  =
+    pcDataCon staticNameDataConName [] (replicate 3 stringTy) staticNameTyCon
+
+staticSptEntryTy :: Type
+staticSptEntryTy = mkTyConTy staticSptEntryTyCon
+
+staticSptEntryTyCon :: TyCon
+staticSptEntryTyCon =
+    pcNonRecDataTyCon staticSptEntryTyConName Nothing [] [staticSptEntryDataCon]
+
+staticSptEntryDataCon :: DataCon
+staticSptEntryDataCon =
+    let dc_name  = staticSptEntryDataConName
+        arg_tys  = [ staticNameTy, alphaTy ]
+        modu     = ASSERT( isExternalName dc_name )
+                   nameModule dc_name
+        wrk_key  = incrUnique (nameUnique dc_name)
+        wrk_occ  = mkDataConWorkerOcc (nameOccName dc_name)
+        wrk_name = mkWiredInName modu wrk_occ wrk_key
+                             (AnId (dataConWorkId data_con)) UserSyntax
+        data_con = mkDataCon
+          dc_name
+          False
+          (map (const HsNoBang) arg_tys)
+          []       -- No labelled fields
+          []       -- No univerally quantified type variables
+          [alphaTyVar] -- Existentially quantified type variables
+          []       -- No equality spec
+          []       -- No theta
+          arg_tys  -- Argument types
+          staticSptEntryTy -- Result type
+          staticSptEntryTyCon -- Representation type constructor
+          []      -- No stupid theta
+          (mkDataConWorkId wrk_name data_con) -- Worker Id
+          NoDataConRep    -- No data constructor representation
+
+     in data_con
+\end{code}
+
 Promoted Booleans
 
 \begin{code}