Separate StablePtr and StableName tables (#7674)

To improve performance of StablePtr.

1 files changed, 264 insertions, 196 deletions

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));
+                    }
+                }
+            });
     }
 }