Separate StablePtr and StableName tables (#7674)

To improve performance of StablePtr.

11 files changed, 337 insertions, 230 deletions

diff --git a/rts/Hash.c b/rts/Hash.c
index 9c9b2bce42..9ab8ffb53e 100644
--- a/rts/Hash.c
+++ b/rts/Hash.c
@@ -392,3 +392,8 @@ exitHashTable(void)
 {
     /* nothing to do */
 }
+
+int keyCountHashTable (HashTable *table)
+{
+    return table->kcount;
+}
diff --git a/rts/Hash.h b/rts/Hash.h
index 727c04298c..d22caba555 100644
--- a/rts/Hash.h
+++ b/rts/Hash.h
@@ -19,6 +19,8 @@ void *      lookupHashTable ( HashTable *table, StgWord key );
 void        insertHashTable ( HashTable *table, StgWord key, void *data );
 void *      removeHashTable ( HashTable *table, StgWord key, void *data );
 
+int keyCountHashTable (HashTable *table);
+
 /* 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).
@@ -41,7 +43,7 @@ HashTable * allocHashTable_(HashFunction *hash, CompareFunction *compare);
 int hashWord(HashTable *table, StgWord key);
 int hashStr(HashTable *table, char *key);
 
-/* Freeing hash tables 
+/* Freeing hash tables
  */
 void freeHashTable ( HashTable *table, void (*freeDataFun)(void *) );
 
@@ -50,4 +52,3 @@ void exitHashTable ( void );
 #include "EndPrivate.h"
 
 #endif /* HASH_H */
-
diff --git a/rts/HsFFI.c b/rts/HsFFI.c
index 38a520da00..856536f5aa 100644
--- a/rts/HsFFI.c
+++ b/rts/HsFFI.c
@@ -27,6 +27,16 @@ hs_perform_gc(void)
     performMajorGC();
 }
 
+void hs_lock_stable_tables (void)
+{
+    stableLock();
+}
+
+void hs_unlock_stable_tables (void)
+{
+    stableUnlock();
+}
+
 void
 hs_free_stable_ptr(HsStablePtr sp)
 {
@@ -36,6 +46,14 @@ hs_free_stable_ptr(HsStablePtr sp)
 }
 
 void
+hs_free_stable_ptr_unsafe(HsStablePtr sp)
+{
+    /* The cast is for clarity only, both HsStablePtr and StgStablePtr are
+       typedefs for void*. */
+    freeStablePtrUnsafe((StgStablePtr)sp);
+}
+
+void
 hs_free_fun_ptr(HsFunPtr fp)
 {
     /* I simply *love* all these similar names... */
diff --git a/rts/Linker.c b/rts/Linker.c
index ef4f924bca..cf4f350af1 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -1112,7 +1112,10 @@ typedef struct _RtsSymbolVal {
       SymI_HasProto(hs_set_argv)                                        \
       SymI_HasProto(hs_add_root)                                        \
       SymI_HasProto(hs_perform_gc)                                      \
+      SymI_HasProto(hs_lock_stable_tables)                              \
+      SymI_HasProto(hs_unlock_stable_tables)                            \
       SymI_HasProto(hs_free_stable_ptr)                                 \
+      SymI_HasProto(hs_free_stable_ptr_unsafe)                          \
       SymI_HasProto(hs_free_fun_ptr)                                    \
       SymI_HasProto(hs_hpc_rootModule)                                  \
       SymI_HasProto(hs_hpc_module)                                      \
@@ -1213,6 +1216,7 @@ typedef struct _RtsSymbolVal {
       SymI_HasProto(startupHaskell)                                     \
       SymI_HasProto(shutdownHaskell)                                    \
       SymI_HasProto(shutdownHaskellAndExit)                             \
+      SymI_HasProto(stable_name_table)                                  \
       SymI_HasProto(stable_ptr_table)                                   \
       SymI_HasProto(stackOverflow)                                      \
       SymI_HasProto(stg_CAF_BLACKHOLE_info)                             \
@@ -4113,7 +4117,7 @@ ocResolve_PEi386 ( ObjectCode* oc )
 #    define R_X86_64_PC64 24
 #  endif
 
-/* 
+/*
  * Workaround for libc implementations (e.g. eglibc) with incomplete
  * relocation lists
  */
@@ -4992,7 +4996,7 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
                   | (offset & 0x01fe);
             break;
          }
-         
+
          case R_ARM_THM_JUMP11:
          {
             StgWord16 *word = (StgWord16 *)P;
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index ebcee6a1d4..f4e80e9c35 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -1,3 +1,4 @@
+/* -*- tab-width: 8 -*- */
 /* -----------------------------------------------------------------------------
  *
  * (c) The GHC Team, 1998-2012
@@ -1513,22 +1514,21 @@ stg_makeStableNamezh ( P_ obj )
 {
     W_ index, sn_obj;
 
-    ALLOC_PRIM_P (SIZEOF_StgStableName, stg_makeStableNamezh, obj);
-  
     (index) = ccall lookupStableName(obj "ptr");
 
     /* Is there already a StableName for this heap object?
-     *  stable_ptr_table is a pointer to an array of snEntry structs.
+     *  stable_name_table is a pointer to an array of snEntry structs.
      */
-    if ( snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry) == NULL ) {
-	sn_obj = Hp - SIZEOF_StgStableName + WDS(1);
-	SET_HDR(sn_obj, stg_STABLE_NAME_info, CCCS);
-	StgStableName_sn(sn_obj) = index;
-	snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry) = sn_obj;
+    if ( snEntry_sn_obj(W_[stable_name_table] + index*SIZEOF_snEntry) == NULL ) {
+        ALLOC_PRIM (SIZEOF_StgStableName);
+        sn_obj = Hp - SIZEOF_StgStableName + WDS(1);
+        SET_HDR(sn_obj, stg_STABLE_NAME_info, CCCS);
+        StgStableName_sn(sn_obj) = index;
+        snEntry_sn_obj(W_[stable_name_table] + index*SIZEOF_snEntry) = sn_obj;
     } else {
-	sn_obj = snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry);
+        sn_obj = snEntry_sn_obj(W_[stable_name_table] + index*SIZEOF_snEntry);
     }
-    
+
     return (sn_obj);
 }
 
@@ -1543,7 +1543,7 @@ stg_makeStablePtrzh ( P_ obj )
 stg_deRefStablePtrzh ( P_ sp )
 {
     W_ r;
-    r = snEntry_addr(W_[stable_ptr_table] + sp*SIZEOF_snEntry);
+    r = spEntry_addr(W_[stable_ptr_table] + sp*SIZEOF_spEntry);
     return (r);
 }
 
diff --git a/rts/RetainerProfile.c b/rts/RetainerProfile.c
index 44df06a40d..4e7ed3e222 100644
--- a/rts/RetainerProfile.c
+++ b/rts/RetainerProfile.c
@@ -1772,7 +1772,7 @@ computeRetainerSet( void )
 	retainRoot(NULL, (StgClosure **)&weak);
 
     // Consider roots from the stable ptr table.
-    markStablePtrTable(retainRoot, NULL);
+    markStableTables(retainRoot, NULL);
 
     // The following code resets the rs field of each unvisited mutable
     // object (computing sumOfNewCostExtra and updating costArray[] when
diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index f5c29f4a70..e83d047695 100644
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -185,7 +185,7 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
     initStorage();
 
     /* initialise the stable pointer table */
-    initStablePtrTable();
+    initStableTables();
 
     /* Add some GC roots for things in the base package that the RTS
      * knows about.  We don't know whether these turn out to be CAFs
@@ -377,7 +377,7 @@ hs_exit_(rtsBool wait_foreign)
     freeFileLocking();
 
     /* free the stable pointer table */
-    exitStablePtrTable();
+    exitStableTables();
 
 #if defined(DEBUG)
     /* free the thread label table */
diff --git a/rts/Stable.c b/rts/Stable.c
index 39b26173d8..ff3843ecd7 100644
--- a/rts/Stable.c
+++ b/rts/Stable.c
@@ -1,3 +1,5 @@
+/* -*- tab-width: 4 -*- */
+
 /* -----------------------------------------------------------------------------
  *
  * (c) The GHC Team, 1998-2002
@@ -53,6 +55,11 @@
   it will produce. For example, this is used when interfacing to an X
   widgets library to allow a direct implementation of callbacks.
 
+  One final reason is that we may want to store composite Haskell
+  values in data structures implemented in the C side. Serializing and
+  deserializing these structures into unboxed form suitable for C may
+  be more expensive than maintaining the extra layer of indirection of
+  stable pointers.
 
   The @makeStablePointer :: a -> IO (StablePtr a)@ function
   converts a value into a stable pointer.  It is part of the @PrimIO@
@@ -62,24 +69,38 @@
   \begin{verbatim}
   makeStablePtr#  :: a -> State# RealWorld -> (# RealWorld, a #)
   freeStablePtr#  :: StablePtr# a -> State# RealWorld -> State# RealWorld
-  deRefStablePtr# :: StablePtr# a -> State# RealWorld -> 
+  deRefStablePtr# :: StablePtr# a -> State# RealWorld ->
         (# State# RealWorld, a #)
   \end{verbatim}
 
   There may be additional functions on the C side to allow evaluation,
   application, etc of a stable pointer.
 
+  Stable Pointers are exported to the outside world as indices and not
+  pointers, because the stable pointer table is allowed to be
+  reallocated for growth. The table is never shrunk for its space to
+  be reclaimed.
+
+  Future plans for stable ptrs include distinguishing them by the
+  generation of the pointed object. See
+  http://hackage.haskell.org/trac/ghc/ticket/7670 for details.
 */
 
-snEntry *stable_ptr_table = NULL;
-static snEntry *stable_ptr_free = NULL;
+snEntry *stable_name_table = NULL;
+static snEntry *stable_name_free = NULL;
+static unsigned int SNT_size = 0;
+#define INIT_SNT_SIZE 64
 
+spEntry *stable_ptr_table = NULL;
+static spEntry *stable_ptr_free = NULL;
 static unsigned int SPT_size = 0;
+#define INIT_SPT_SIZE 64
 
 #ifdef THREADED_RTS
 Mutex stable_mutex;
 #endif
 
+static void enlargeStableNameTable(void);
 static void enlargeStablePtrTable(void);
 
 /* This hash table maps Haskell objects to stable names, so that every
@@ -117,57 +138,74 @@ static void enlargeStablePtrTable(void);
 
 static HashTable *addrToStableHash = NULL;
 
-#define INIT_SPT_SIZE 64
-
 STATIC_INLINE void
-initFreeList(snEntry *table, nat n, snEntry *free)
+initSnEntryFreeList(snEntry *table, nat n, snEntry *free)
 {
   snEntry *p;
-
   for (p = table + n - 1; p >= table; p--) {
     p->addr   = (P_)free;
     p->old    = NULL;
-    p->ref    = 0;
     p->sn_obj = NULL;
     free = p;
   }
+  stable_name_free = table;
+}
+
+STATIC_INLINE void
+initSpEntryFreeList(spEntry *table, nat n, spEntry *free)
+{
+  spEntry *p;
+  for (p = table + n - 1; p >= table; p--) {
+      p->addr = (P_)free;
+      free = p;
+  }
   stable_ptr_free = table;
 }
 
 void
-initStablePtrTable(void)
+initStableTables(void)
 {
-	if (SPT_size > 0)
-		return;
-
-    SPT_size = INIT_SPT_SIZE;
-    stable_ptr_table = stgMallocBytes(SPT_size * sizeof(snEntry),
-				      "initStablePtrTable");
-
+    if (SNT_size > 0) return;
+    SNT_size = INIT_SNT_SIZE;
+    stable_name_table = stgMallocBytes(SNT_size * sizeof *stable_name_table,
+                                       "initStableNameTable");
     /* we don't use index 0 in the stable name table, because that
      * would conflict with the hash table lookup operations which
      * return NULL if an entry isn't found in the hash table.
      */
-    initFreeList(stable_ptr_table+1,INIT_SPT_SIZE-1,NULL);
+    initSnEntryFreeList(stable_name_table + 1,INIT_SNT_SIZE-1,NULL);
     addrToStableHash = allocHashTable();
 
+    if (SPT_size > 0) return;
+    SPT_size = INIT_SPT_SIZE;
+    stable_ptr_table = stgMallocBytes(SPT_size * sizeof *stable_ptr_table,
+                                      "initStablePtrTable");
+    initSpEntryFreeList(stable_ptr_table,INIT_SPT_SIZE,NULL);
+
 #ifdef THREADED_RTS
     initMutex(&stable_mutex);
 #endif
 }
 
 void
-exitStablePtrTable(void)
+exitStableTables(void)
 {
-  if (addrToStableHash)
-    freeHashTable(addrToStableHash, NULL);
-  addrToStableHash = NULL;
-  if (stable_ptr_table)
-    stgFree(stable_ptr_table);
-  stable_ptr_table = NULL;
-  SPT_size = 0;
+    if (addrToStableHash)
+        freeHashTable(addrToStableHash, NULL);
+    addrToStableHash = NULL;
+
+    if (stable_name_table)
+        stgFree(stable_name_table);
+    stable_name_table = NULL;
+    SNT_size = 0;
+
+    if (stable_ptr_table)
+        stgFree(stable_ptr_table);
+    stable_ptr_table = NULL;
+    SPT_size = 0;
+
 #ifdef THREADED_RTS
-  closeMutex(&stable_mutex);
+    closeMutex(&stable_mutex);
 #endif
 }
 
@@ -203,8 +241,8 @@ lookupStableName_(StgPtr p)
   StgWord sn;
   void* sn_tmp;
 
-  if (stable_ptr_free == NULL) {
-    enlargeStablePtrTable();
+  if (stable_name_free == NULL) {
+    enlargeStableNameTable();
   }
 
   /* removing indirections increases the likelihood
@@ -217,24 +255,23 @@ lookupStableName_(StgPtr p)
 
   sn_tmp = lookupHashTable(addrToStableHash,(W_)p);
   sn = (StgWord)sn_tmp;
-  
+
   if (sn != 0) {
-    ASSERT(stable_ptr_table[sn].addr == p);
+    ASSERT(stable_name_table[sn].addr == p);
     debugTrace(DEBUG_stable, "cached stable name %ld at %p",sn,p);
     return sn;
-  } else {
-    sn = stable_ptr_free - stable_ptr_table;
-    stable_ptr_free  = (snEntry*)(stable_ptr_free->addr);
-    stable_ptr_table[sn].ref = 0;
-    stable_ptr_table[sn].addr = p;
-    stable_ptr_table[sn].sn_obj = NULL;
-    /* debugTrace(DEBUG_stable, "new stable name %d at %p\n",sn,p); */
-    
-    /* add the new stable name to the hash table */
-    insertHashTable(addrToStableHash, (W_)p, (void *)sn);
-
-    return sn;
   }
+
+  sn = stable_name_free - stable_name_table;
+  stable_name_free  = (snEntry*)(stable_name_free->addr);
+  stable_name_table[sn].addr = p;
+  stable_name_table[sn].sn_obj = NULL;
+  /* debugTrace(DEBUG_stable, "new stable name %d at %p\n",sn,p); */
+
+  /* add the new stable name to the hash table */
+  insertHashTable(addrToStableHash, (W_)p, (void *)sn);
+
+  return sn;
 }
 
 StgWord
@@ -242,7 +279,7 @@ lookupStableName(StgPtr p)
 {
     StgWord res;
 
-    initStablePtrTable();
+    initStableTables();
     ACQUIRE_LOCK(&stable_mutex);
     res = lookupStableName_(p);
     RELEASE_LOCK(&stable_mutex);
@@ -250,66 +287,85 @@ lookupStableName(StgPtr p)
 }
 
 STATIC_INLINE void
-freeStableName(snEntry *sn)
+freeSnEntry(snEntry *sn)
 {
   ASSERT(sn->sn_obj == NULL);
-  if (sn->addr != NULL) {
+  if(sn->addr != NULL) {
+      /* StableName object may die before pointee, in which case we
+       * need to remove from hash table, or after pointee, in which
+       * case addr==NULL and we already removed it. */
       removeHashTable(addrToStableHash, (W_)sn->addr, NULL);
   }
-  sn->addr = (P_)stable_ptr_free;
-  stable_ptr_free = sn;
+  sn->addr = (P_)stable_name_free;
+  stable_name_free = sn;
+}
+
+STATIC_INLINE void
+freeSpEntry(spEntry *sp)
+{
+    sp->addr = (P_)stable_ptr_free;
+    stable_ptr_free = sp;
 }
 
 StgStablePtr
 getStablePtr(StgPtr p)
 {
-  StgWord sn;
+  StgWord sp;
 
-  initStablePtrTable();
+  initStableTables();
   ACQUIRE_LOCK(&stable_mutex);
-  sn = lookupStableName_(p);
-  stable_ptr_table[sn].ref++;
+  if (!stable_ptr_free) enlargeStablePtrTable();
+  sp = stable_ptr_free - stable_ptr_table;
+  stable_ptr_free  = (spEntry*)(stable_ptr_free->addr);
+  stable_ptr_table[sp].addr = p;
   RELEASE_LOCK(&stable_mutex);
-  return (StgStablePtr)(sn);
+  return (StgStablePtr)(sp);
 }
 
 void
-freeStablePtr(StgStablePtr sp)
+freeStablePtrUnsafe(StgStablePtr sp)
 {
-    snEntry *sn;
+    ASSERT((StgWord)sp < SPT_size);
+    freeSpEntry(&stable_ptr_table[(StgWord)sp]);
+}
 
-	initStablePtrTable();
+void
+freeStablePtr(StgStablePtr sp)
+{
+    initStableTables();
     ACQUIRE_LOCK(&stable_mutex);
+    freeStablePtrUnsafe(sp);
+    RELEASE_LOCK(&stable_mutex);
+}
 
-    sn = &stable_ptr_table[(StgWord)sp];
-    
-    ASSERT((StgWord)sp < SPT_size  &&  sn->addr != NULL  &&  sn->ref > 0);
-
-    sn->ref--;
+static void
+enlargeStableNameTable(void)
+{
+    nat old_SNT_size = SNT_size;
 
-    // If this entry has no StableName attached, then just free it
-    // immediately.  This is important; it might be a while before the
-    // next major GC which actually collects the entry.
-    if (sn->sn_obj == NULL && sn->ref == 0) {
-	freeStableName(sn);
-    }
+    // 2nd and subsequent times
+    SNT_size *= 2;
+    stable_name_table =
+        stgReallocBytes(stable_name_table,
+                        SNT_size * sizeof *stable_name_table,
+                        "enlargeStableNameTable");
 
-    RELEASE_LOCK(&stable_mutex);
+    initSnEntryFreeList(stable_name_table + old_SNT_size, old_SNT_size, NULL);
 }
 
 static void
 enlargeStablePtrTable(void)
 {
-  nat old_SPT_size = SPT_size;
+    nat old_SPT_size = SPT_size;
 
     // 2nd and subsequent times
-  SPT_size *= 2;
-  stable_ptr_table =
-    stgReallocBytes(stable_ptr_table,
-		      SPT_size * sizeof(snEntry),
-		      "enlargeStablePtrTable");
+    SPT_size *= 2;
+    stable_ptr_table =
+        stgReallocBytes(stable_ptr_table,
+                        SPT_size * sizeof *stable_ptr_table,
+                        "enlargeStablePtrTable");
 
-  initFreeList(stable_ptr_table + old_SPT_size, old_SPT_size, NULL);
+    initSpEntryFreeList(stable_ptr_table + old_SPT_size, old_SPT_size, NULL);
 }
 
 /* -----------------------------------------------------------------------------
@@ -318,82 +374,110 @@ enlargeStablePtrTable(void)
  * -------------------------------------------------------------------------- */
 
 void
-stablePtrPreGC(void)
+stableLock(void)
 {
+    initStableTables();
     ACQUIRE_LOCK(&stable_mutex);
 }
 
 void
-stablePtrPostGC(void)
+stableUnlock(void)
 {
     RELEASE_LOCK(&stable_mutex);
 }
 
 /* -----------------------------------------------------------------------------
  * Treat stable pointers as roots for the garbage collector.
- *
- * A stable pointer is any stable name entry with a ref > 0.  We'll
- * take the opportunity to zero the "keep" flags at the same time.
  * -------------------------------------------------------------------------- */
 
-void
+#define FOR_EACH_STABLE_PTR(p, CODE)                                    \
+    do {                                                                \
+        spEntry *p;                                                     \
+        spEntry *__end_ptr = &stable_ptr_table[SPT_size];               \
+        for (p = stable_ptr_table; p < __end_ptr; p++) {                \
+            /* Internal pointers are free slots. NULL is last in free */ \
+            /* list. */                                                 \
+            if (p->addr &&                                              \
+                (p->addr < (P_)stable_ptr_table || p->addr >= (P_)__end_ptr)) \
+            {                                                           \
+                do { CODE } while(0);                                   \
+            }                                                           \
+        }                                                               \
+    } while(0)
+
+#define FOR_EACH_STABLE_NAME(p, CODE)                                   \
+    do {                                                                \
+        snEntry *p;                                                     \
+        snEntry *__end_ptr = &stable_name_table[SNT_size];              \
+        for (p = stable_name_table + 1; p < __end_ptr; p++) {           \
+            /* Internal pointers are free slots.  */                    \
+            /* If p->addr == NULL, it's a */                            \
+            /* stable name where the object has been GC'd, but the */   \
+            /* StableName object (sn_obj) is still alive. */            \
+            if ((p->addr < (P_)stable_name_table ||                     \
+                 p->addr >= (P_)__end_ptr))                             \
+            {                                                           \
+                /* NOTE: There is an ambiguity here if p->addr == NULL */ \
+                /* it is either the last item in the free list or it */ \
+                /* is a stable name whose pointee died. sn_obj == NULL */ \
+                /* disambiguates as last free list item. */             \
+                do { CODE } while(0);                                   \
+            }                                                           \
+        }                                                               \
+    } while(0)
+
+STATIC_INLINE void
 markStablePtrTable(evac_fn evac, void *user)
 {
-    snEntry *p, *end_stable_ptr_table;
-    StgPtr q;
-    
-    end_stable_ptr_table = &stable_ptr_table[SPT_size];
-    
-    // Mark all the stable *pointers* (not stable names).
-    // _starting_ at index 1; index 0 is unused.
-    for (p = stable_ptr_table+1; p < end_stable_ptr_table; p++) {
-	q = p->addr;
-
-	// Internal pointers are free slots.  If q == NULL, it's a
-	// stable name where the object has been GC'd, but the
-	// StableName object (sn_obj) is still alive.
-	if (q && (q < (P_)stable_ptr_table || q >= (P_)end_stable_ptr_table)) {
-
-	    // save the current addr away: we need to be able to tell
-	    // whether the objects moved in order to be able to update
-	    // the hash table later.
-	    p->old = p->addr;
-
-	    // if the ref is non-zero, treat addr as a root
-	    if (p->ref != 0) {
-		evac(user, (StgClosure **)&p->addr);
-	    }
-	}
-    }
+    FOR_EACH_STABLE_PTR(p, evac(user, (StgClosure **)&p->addr););
+}
+
+STATIC_INLINE void
+rememberOldStableNameAddresses(void)
+{
+    /* TODO: Only if !full GC */
+    FOR_EACH_STABLE_NAME(p, p->old = p->addr;);
+}
+
+void
+markStableTables(evac_fn evac, void *user)
+{
+    markStablePtrTable(evac, user);
+    rememberOldStableNameAddresses();
 }
 
 /* -----------------------------------------------------------------------------
  * Thread the stable pointer table for compacting GC.
- * 
+ *
  * Here we must call the supplied evac function for each pointer into
- * the heap from the stable pointer table, because the compacting
+ * the heap from the stable tables, because the compacting
  * collector may move the object it points to.
  * -------------------------------------------------------------------------- */
 
-void
+STATIC_INLINE void
+threadStableNameTable( evac_fn evac, void *user )
+{
+    FOR_EACH_STABLE_NAME(p, {
+        if (p->sn_obj != NULL) {
+            evac(user, (StgClosure **)&p->sn_obj);
+        }
+        if (p->addr != NULL) {
+            evac(user, (StgClosure **)&p->addr);
+        }
+    });
+}
+
+STATIC_INLINE void
 threadStablePtrTable( evac_fn evac, void *user )
 {
-    snEntry *p, *end_stable_ptr_table;
-    StgPtr q;
-    
-    end_stable_ptr_table = &stable_ptr_table[SPT_size];
-    
-    for (p = stable_ptr_table+1; p < end_stable_ptr_table; p++) {
-	
-	if (p->sn_obj != NULL) {
-	    evac(user, (StgClosure **)&p->sn_obj);
-	}
-
-	q = p->addr;
-	if (q && (q < (P_)stable_ptr_table || q >= (P_)end_stable_ptr_table)) {
-	    evac(user, (StgClosure **)&p->addr);
-	}
-    }
+    FOR_EACH_STABLE_PTR(p, evac(user, (StgClosure **)&p->addr););
+}
+
+void
+threadStableTables( evac_fn evac, void *user )
+{
+    threadStableNameTable(evac, user);
+    threadStablePtrTable(evac, user);
 }
 
 /* -----------------------------------------------------------------------------
@@ -411,49 +495,41 @@ threadStablePtrTable( evac_fn evac, void *user )
  * -------------------------------------------------------------------------- */
 
 void
-gcStablePtrTable( void )
+gcStableTables( void )
 {
-    snEntry *p, *end_stable_ptr_table;
-    StgPtr q;
-    
-    end_stable_ptr_table = &stable_ptr_table[SPT_size];
-    
-    // NOTE: _starting_ at index 1; index 0 is unused.
-    for (p = stable_ptr_table + 1; p < end_stable_ptr_table; p++) {
-	
-	// Update the pointer to the StableName object, if there is one
-	if (p->sn_obj != NULL) {
-	    p->sn_obj = isAlive(p->sn_obj);
-	}
-	
-	// Internal pointers are free slots.  If q == NULL, it's a
-	// stable name where the object has been GC'd, but the
-	// StableName object (sn_obj) is still alive.
-	q = p->addr;
-	if (q && (q < (P_)stable_ptr_table || q >= (P_)end_stable_ptr_table)) {
-
-	    // StableNames only:
-	    if (p->ref == 0) {
-		if (p->sn_obj == NULL) {
-		    // StableName object is dead
-		    freeStableName(p);
-		    debugTrace(DEBUG_stable, "GC'd Stable name %ld",
-			       (long)(p - stable_ptr_table));
-		    continue;
-		    
-		} else {
-		  p->addr = (StgPtr)isAlive((StgClosure *)p->addr);
-		  debugTrace(DEBUG_stable, 
-			     "stable name %ld still alive at %p, ref %ld\n",
-			     (long)(p - stable_ptr_table), p->addr, p->ref);
-		}
-	    }
-	}
-    }
+    FOR_EACH_STABLE_NAME(
+        p, {
+            // Update the pointer to the StableName object, if there is one
+            if (p->sn_obj != NULL) {
+                p->sn_obj = isAlive(p->sn_obj);
+                if(p->sn_obj == NULL) {
+                    // StableName object died
+                    debugTrace(DEBUG_stable, "GC'd StableName %ld (addr=%p)",
+                               (long)(p - stable_name_table), p->addr);
+                    freeSnEntry(p);
+                    /* Can't "continue", so use goto */
+                    goto next_stable_name;
+                }
+            }
+            /* If sn_obj became NULL, the object died, and addr is now
+             * invalid. But if sn_obj was null, then the StableName
+             * object may not have been created yet, while the pointee
+             * already exists and must be updated to new location. */
+            if (p->addr != NULL) {
+                p->addr = (StgPtr)isAlive((StgClosure *)p->addr);
+                if(p->addr == NULL) {
+                    // StableName pointee died
+                    debugTrace(DEBUG_stable, "GC'd pointee %ld",
+                               (long)(p - stable_name_table));
+                }
+            }
+    next_stable_name:
+            if (0) {}
+        });
 }
 
 /* -----------------------------------------------------------------------------
- * Update the StablePtr/StableName hash table
+ * Update the StableName hash table
  *
  * The boolean argument 'full' indicates that a major collection is
  * being done, so we might as well throw away the hash table and build
@@ -462,39 +538,31 @@ gcStablePtrTable( void )
  * -------------------------------------------------------------------------- */
 
 void
-updateStablePtrTable(rtsBool full)
+updateStableTables(rtsBool full)
 {
-    snEntry *p, *end_stable_ptr_table;
-    
-    if (full && addrToStableHash != NULL) {
-	freeHashTable(addrToStableHash,NULL);
-	addrToStableHash = allocHashTable();
+    if (full && addrToStableHash != NULL && 0 != keyCountHashTable(addrToStableHash)) {
+        freeHashTable(addrToStableHash,NULL);
+        addrToStableHash = allocHashTable();
     }
-    
-    end_stable_ptr_table = &stable_ptr_table[SPT_size];
-    
-    // NOTE: _starting_ at index 1; index 0 is unused.
-    for (p = stable_ptr_table + 1; p < end_stable_ptr_table; p++) {
-	
-	if (p->addr == NULL) {
-	    if (p->old != NULL) {
-		// The target has been garbage collected.  Remove its
-		// entry from the hash table.
-		removeHashTable(addrToStableHash, (W_)p->old, NULL);
-		p->old = NULL;
-	    }
-	}
-	else if (p->addr < (P_)stable_ptr_table 
-		 || p->addr >= (P_)end_stable_ptr_table) {
-	    // Target still alive, Re-hash this stable name 
-	    if (full) {
-		insertHashTable(addrToStableHash, (W_)p->addr, 
-				(void *)(p - stable_ptr_table));
-	    } else if (p->addr != p->old) {
-		removeHashTable(addrToStableHash, (W_)p->old, NULL);
-		insertHashTable(addrToStableHash, (W_)p->addr, 
-				(void *)(p - stable_ptr_table));
-	    }
-	}
+
+    if(full) {
+        FOR_EACH_STABLE_NAME(
+            p, {
+                if (p->addr != NULL) {
+                    // Target still alive, Re-hash this stable name
+                    insertHashTable(addrToStableHash, (W_)p->addr, (void *)(p - stable_name_table));
+                }
+            });
+    } else {
+        FOR_EACH_STABLE_NAME(
+            p, {
+                if (p->addr != p->old) {
+                    removeHashTable(addrToStableHash, (W_)p->old, NULL);
+                    /* Movement happened: */
+                    if (p->addr != NULL) {
+                        insertHashTable(addrToStableHash, (W_)p->addr, (void *)(p - stable_name_table));
+                    }
+                }
+            });
     }
 }
diff --git a/rts/Stable.h b/rts/Stable.h
index bec932af97..4786d477f3 100644
--- a/rts/Stable.h
+++ b/rts/Stable.h
@@ -21,17 +21,28 @@
 
 void    freeStablePtr         ( StgStablePtr sp );
 
-void    initStablePtrTable    ( void );
-void    exitStablePtrTable    ( void );
-StgWord lookupStableName      ( StgPtr p );
+/* Use the "Unsafe" one after manually locking with stableLock/stableUnlock */
+void    freeStablePtrUnsafe   ( StgStablePtr sp );
 
-void    markStablePtrTable    ( evac_fn evac, void *user );
-void    threadStablePtrTable  ( evac_fn evac, void *user );
-void    gcStablePtrTable      ( void );
-void    updateStablePtrTable  ( rtsBool full );
+void    initStableTables      ( void );
+void    exitStableTables      ( void );
+StgWord lookupStableName      ( StgPtr p );
 
-void    stablePtrPreGC        ( void );
-void    stablePtrPostGC       ( void );
+/* Call given function on every stable ptr. markStableTables depends
+ * on the function updating its pointers in case the object is
+ * moved. */
+/* TODO: This also remembers old stable name addresses, which isn't
+ * necessary in some contexts markStableTables is called from.
+ * Consider splitting it.
+ */
+void    markStableTables      ( evac_fn evac, void *user );
+
+void    threadStableTables    ( evac_fn evac, void *user );
+void    gcStableTables        ( void );
+void    updateStableTables    ( rtsBool full );
+
+void    stableLock            ( void );
+void    stableUnlock          ( void );
 
 #ifdef THREADED_RTS
 // needed by Schedule.c:forkProcess()
diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c
index 02183c6946..7c89418ab9 100644
--- a/rts/sm/Compact.c
+++ b/rts/sm/Compact.c
@@ -964,7 +964,7 @@ compact(StgClosure *static_objects)
     thread_static(static_objects /* ToDo: ok? */);
 
     // the stable pointer table
-    threadStablePtrTable((evac_fn)thread_root, NULL);
+    threadStableTables((evac_fn)thread_root, NULL);
 
     // the CAF list (used by GHCi)
     markCAFs((evac_fn)thread_root, NULL);
diff --git a/rts/sm/GC.c b/rts/sm/GC.c
index ea0e4030bd..dfebd55334 100644
--- a/rts/sm/GC.c
+++ b/rts/sm/GC.c
@@ -220,7 +220,7 @@ GarbageCollect (nat collect_gen,
   stat_startGC(cap, gct);
 
   // lock the StablePtr table
-  stablePtrPreGC();
+  stableLock();
 
 #ifdef DEBUG
   mutlist_MUTVARS = 0;
@@ -390,7 +390,7 @@ GarbageCollect (nat collect_gen,
   initWeakForGC();
 
   // Mark the stable pointer table.
-  markStablePtrTable(mark_root, gct);
+  markStableTables(mark_root, gct);
 
   /* -------------------------------------------------------------------------
    * Repeatedly scavenge all the areas we know about until there's no
@@ -420,7 +420,7 @@ GarbageCollect (nat collect_gen,
   shutdown_gc_threads(gct->thread_index);
 
   // Now see which stable names are still alive.
-  gcStablePtrTable();
+  gcStableTables();
 
 #ifdef THREADED_RTS
   if (n_gc_threads == 1) {
@@ -698,15 +698,15 @@ GarbageCollect (nat collect_gen,
   }
 
   // Update the stable pointer hash table.
-  updateStablePtrTable(major_gc);
+  updateStableTables(major_gc);
 
   // unlock the StablePtr table.  Must be before scheduleFinalizers(),
   // because a finalizer may call hs_free_fun_ptr() or
   // hs_free_stable_ptr(), both of which access the StablePtr table.
-  stablePtrPostGC();
+  stableUnlock();
 
   // Start any pending finalizers.  Must be after
-  // updateStablePtrTable() and stablePtrPostGC() (see #4221).
+  // updateStableTables() and stableUnlock() (see #4221).
   RELEASE_SM_LOCK;
   scheduleFinalizers(cap, old_weak_ptr_list);
   ACQUIRE_SM_LOCK;