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

6 files changed, 114 insertions, 0 deletions

diff --git a/rts/Hash.c b/rts/Hash.c
index b91d70c219..1881092851 100644
--- a/rts/Hash.c
+++ b/rts/Hash.c
@@ -206,6 +206,29 @@ lookupHashTable(HashTable *table, StgWord key)
     return NULL;
 }
 
+// Puts up to keys_sz keys of the hash table into the given array. Returns the
+// actual amount of keys that have been retrieved.
+//
+// If the table is modified concurrently, the function behavior is undefined.
+//
+int keysHashTable(HashTable *table, StgWord keys[], int szKeys) {
+    int segment;
+    int k = 0;
+    for(segment=0;segment<HDIRSIZE && table->dir[segment];segment+=1) {
+        int index;
+        for(index=0;index<HSEGSIZE;index+=1) {
+            HashList *hl;
+            for(hl=table->dir[segment][index];hl;hl=hl->next) {
+                if (k == szKeys)
+                  return k;
+                keys[k] = hl->key;
+                k += 1;
+            }
+        }
+    }
+    return k;
+}
+
 /* -----------------------------------------------------------------------------
  * We allocate the hashlist cells in large chunks to cut down on malloc
  * overhead.  Although we keep a free list of hashlist cells, we make
diff --git a/rts/Hash.h b/rts/Hash.h
index d22caba555..e802644659 100644
--- a/rts/Hash.h
+++ b/rts/Hash.h
@@ -21,6 +21,13 @@ void *      removeHashTable ( HashTable *table, StgWord key, void *data );
 
 int keyCountHashTable (HashTable *table);
 
+// Puts up to keys_sz keys of the hash table into the given array. Returns the
+// actual amount of keys that have been retrieved.
+//
+// If the table is modified concurrently, the function behavior is undefined.
+//
+int keysHashTable(HashTable *table, StgWord keys[], int szKeys);
+
 /* Hash table access where the keys are C strings (the strings are
  * assumed to be allocated by the caller, and mustn't be deallocated
  * until the corresponding hash table entry has been removed).
diff --git a/rts/Linker.c b/rts/Linker.c
index 5c7a64e91d..4a0e5eadb1 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -1418,6 +1418,10 @@ typedef struct _RtsSymbolVal {
       SymI_HasProto(stopProfTimer)                                      \
       SymI_HasProto(atomic_inc)                                         \
       SymI_HasProto(atomic_dec)                                         \
+      SymI_HasProto(hs_spt_lookup)                                      \
+      SymI_HasProto(hs_spt_insert)                                      \
+      SymI_HasProto(hs_spt_keys)                                        \
+      SymI_HasProto(hs_spt_key_count)                                   \
       RTS_USER_SIGNALS_SYMBOLS                                          \
       RTS_INTCHAR_SYMBOLS
 
diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index b8201e1651..490f2ead38 100644
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -32,6 +32,7 @@
 #include "sm/BlockAlloc.h"
 #include "Trace.h"
 #include "Stable.h"
+#include "StaticPtrTable.h"
 #include "Hash.h"
 #include "Profiling.h"
 #include "Timer.h"
@@ -395,6 +396,9 @@ hs_exit_(rtsBool wait_foreign)
     /* free file locking tables, if necessary */
     freeFileLocking();
 
+    /* free the Static Pointer Table */
+    exitStaticPtrTable();
+
     /* free the stable pointer table */
     exitStableTables();
 
diff --git a/rts/StaticPtrTable.c b/rts/StaticPtrTable.c
new file mode 100644
index 0000000000..bd450809d0
--- /dev/null
+++ b/rts/StaticPtrTable.c
@@ -0,0 +1,57 @@
+/*
+ * (c)2014 Tweag I/O
+ *
+ * The Static Pointer Table implementation.
+ *
+ * https://ghc.haskell.org/trac/ghc/wiki/StaticPointers
+ * https://ghc.haskell.org/trac/ghc/wiki/StaticPointers/ImplementationPlan
+ *
+ */
+
+#include "Rts.h"
+#include "StaticPtrTable.h"
+#include "Hash.h"
+
+static HashTable * spt = NULL;
+
+/// Hash function for the SPT.
+static int hashFingerprint(HashTable *table, StgWord64 key[2]) {
+  // Take half of the key to compute the hash.
+  return hashWord(table, (StgWord)key[1]);
+}
+
+/// Comparison function for the SPT.
+static int compareFingerprint(StgWord64 ptra[2], StgWord64 ptrb[2]) {
+  return ptra[0] == ptrb[0] && ptra[1] == ptrb[1];
+}
+
+void hs_spt_insert(StgWord64 key[2],void *spe_closure) {
+  // hs_spt_insert is called from constructor functions, so
+  // the SPT needs to be initialized here.
+  if (spt == NULL)
+    spt = allocHashTable_( (HashFunction *)hashFingerprint
+                         , (CompareFunction *)compareFingerprint
+                         );
+
+  getStablePtr(spe_closure);
+  insertHashTable(spt, (StgWord)key, spe_closure);
+}
+
+StgPtr hs_spt_lookup(StgWord64 key[2]) {
+  return spt ? lookupHashTable(spt, (StgWord)key) : NULL;
+}
+
+int hs_spt_keys(StgPtr keys[], int szKeys) {
+  return spt ? keysHashTable(spt, (StgWord*)keys, szKeys) : 0;
+}
+
+int hs_spt_key_count() {
+  return spt ? keyCountHashTable(spt) : 0;
+}
+
+void exitStaticPtrTable() {
+  if (spt) {
+    freeHashTable(spt, NULL);
+    spt = NULL;
+  }
+}
diff --git a/rts/StaticPtrTable.h b/rts/StaticPtrTable.h
new file mode 100644
index 0000000000..4ad126cc38
--- /dev/null
+++ b/rts/StaticPtrTable.h
@@ -0,0 +1,19 @@
+/*-----------------------------------------------------------------------------
+ *
+ * (c)2014 Tweag I/O
+ *
+ * Prototypes for StaticPtrTable.c
+ *
+ * -------------------------------------------------------------------------- */
+
+#ifndef STATICPTRTABLE_H
+#define STATICPTRTABLE_H
+
+#include "BeginPrivate.h"
+
+/** Frees the Static Pointer Table. */
+void exitStaticPtrTable ( void );
+
+#include "EndPrivate.h"
+
+#endif /* STATICPTRTABLE_H */