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.

4 files changed, 73 insertions, 0 deletions

diff --git a/rts/Hash.c b/rts/Hash.c
index b91d70c219..1c167168d2 100644
--- a/rts/Hash.c
+++ b/rts/Hash.c
@@ -16,6 +16,10 @@
 
 #include <string.h>
 
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
 #define HSEGSIZE    1024    /* Size of a single hash table segment */
                             /* Also the minimum size of a hash table */
 #define HDIRSIZE    1024    /* Size of the segment directory */
@@ -99,6 +103,31 @@ hashStr(HashTable *table, char *key)
     return bucket;
 }
 
+int
+hashFingerprint(HashTable *table, uint64_t *key)
+{
+    int h, bucket;
+    char *s;
+
+    s = (char *)key;
+    size_t i;
+    for (i=0, h=0; i< sizeof(uint64_t)*2; ++i, ++s) {
+        h *= 128;
+        h += *s;
+        h = h % 1048583;        /* some random large prime */
+    }
+
+    /* Mod the size of the hash table (a power of 2) */
+    bucket = h & table->mask1;
+
+    if (bucket < table->split) {
+        /* Mod the size of the expanded hash table (also a power of 2) */
+        bucket = h & table->mask2;
+    }
+
+    return bucket;
+}
+
 static int
 compareWord(StgWord key1, StgWord key2)
 {
@@ -111,6 +140,11 @@ compareStr(StgWord key1, StgWord key2)
     return (strcmp((char *)key1, (char *)key2) == 0);
 }
 
+static int
+compareFingerprint(uint64_t *ptra, uint64_t *ptrb) {
+    return (ptra[0]-ptrb[0]==0ULL)?((ptra[1] - ptrb[1] == 0ULL)?0:1):1;
+}
+
 
 /* -----------------------------------------------------------------------------
  * Allocate a new segment of the dynamically growing hash table.
@@ -387,6 +421,13 @@ allocStrHashTable(void)
                            (CompareFunction *)compareStr);
 }
 
+HashTable *
+allocFpHashTable(void)
+{
+    return allocHashTable_((HashFunction *)hashFingerprint,
+                           (CompareFunction *)compareFingerprint);
+}
+
 void
 exitHashTable(void)
 {
diff --git a/rts/Hash.h b/rts/Hash.h
index d22caba555..0d9df2ea98 100644
--- a/rts/Hash.h
+++ b/rts/Hash.h
@@ -9,6 +9,10 @@
 #ifndef HASH_H
 #define HASH_H
 
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
 #include "BeginPrivate.h"
 
 typedef struct hashtable HashTable; /* abstract */
@@ -27,6 +31,10 @@ int keyCountHashTable (HashTable *table);
  */
 HashTable * allocStrHashTable ( void );
 
+/* Hash table access where the keys are fingerprints {uint64_t[2]}
+ */
+HashTable * allocFpHashTable ( void );
+
 #define lookupStrHashTable(table, key)  \
    (lookupHashTable(table, (StgWord)key))
 
@@ -42,6 +50,8 @@ typedef int CompareFunction(StgWord key1, StgWord key2);
 HashTable * allocHashTable_(HashFunction *hash, CompareFunction *compare);
 int hashWord(HashTable *table, StgWord key);
 int hashStr(HashTable *table, char *key);
+int hashFingerprint(HashTable *table, uint64_t* key);
+
 
 /* Freeing hash tables
  */
diff --git a/rts/Linker.c b/rts/Linker.c
index 2c74a0dd35..0e2f3bd8e7 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -1414,6 +1414,8 @@ typedef struct _RtsSymbolVal {
       SymI_HasProto(stopProfTimer)                                      \
       SymI_HasProto(atomic_inc)                                         \
       SymI_HasProto(atomic_dec)                                         \
+      SymI_HasProto(hs_spt_lookup)                                      \
+      SymI_HasProto(hs_spt_insert)                                      \
       RTS_USER_SIGNALS_SYMBOLS                                          \
       RTS_INTCHAR_SYMBOLS
 
diff --git a/rts/SPT.c b/rts/SPT.c
new file mode 100644
index 0000000000..63a3b12d4e
--- /dev/null
+++ b/rts/SPT.c
@@ -0,0 +1,20 @@
+/*
+ * (c)2014 Tweag I/O
+ */
+
+#include "Rts.h"
+#include "Hash.h"
+
+static HashTable * spt = NULL;
+
+void hs_spt_insert(StgWord64 key[2],void *spe_closure) {
+  if (spt == NULL)
+    spt = allocFpHashTable();
+
+  getStablePtr(spe_closure);
+  insertHashTable(spt, (StgWord)key, spe_closure);
+}
+
+StgPtr hs_spt_lookup(StgWord64 key[2]) {
+    return lookupHashTable(spt, (StgWord)key);
+}