--- /dev/null
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2002
+ *
+ * Stable names and stable pointers.
+ *
+ * ---------------------------------------------------------------------------*/
+
+// Make static versions of inline functions in Stable.h:
+#define RTS_STABLE_C
+
+#include "PosixSource.h"
+#include "Rts.h"
+#include "Hash.h"
+#include "RtsUtils.h"
+#include "OSThreads.h"
+#include "Storage.h"
+#include "RtsAPI.h"
+#include "RtsFlags.h"
+#include "OSThreads.h"
+
+/* Comment from ADR's implementation in old RTS:
+
+ This files (together with @ghc/runtime/storage/PerformIO.lhc@ and a
+ small change in @HpOverflow.lc@) consists of the changes in the
+ runtime system required to implement "Stable Pointers". But we're
+ getting a bit ahead of ourselves --- what is a stable pointer and what
+ is it used for?
+
+ When Haskell calls C, it normally just passes over primitive integers,
+ floats, bools, strings, etc. This doesn't cause any problems at all
+ for garbage collection because the act of passing them makes a copy
+ from the heap, stack or wherever they are onto the C-world stack.
+ However, if we were to pass a heap object such as a (Haskell) @String@
+ and a garbage collection occured before we finished using it, we'd run
+ into problems since the heap object might have been moved or even
+ deleted.
+
+ So, if a C call is able to cause a garbage collection or we want to
+ store a pointer to a heap object between C calls, we must be careful
+ when passing heap objects. Our solution is to keep a table of all
+ objects we've given to the C-world and to make sure that the garbage
+ collector collects these objects --- updating the table as required to
+ make sure we can still find the object.
+
+
+ Of course, all this rather begs the question: why would we want to
+ pass a boxed value?
+
+ One very good reason is to preserve laziness across the language
+ interface. Rather than evaluating an integer or a string because it
+ {\em might\/} be required by the C function, we can wait until the C
+ function actually wants the value and then force an evaluation.
+
+ Another very good reason (the motivating reason!) is that the C code
+ might want to execute an object of sort $IO ()$ for the side-effects
+ it will produce. For example, this is used when interfacing to an X
+ widgets library to allow a direct implementation of callbacks.
+
+
+ The @makeStablePointer :: a -> IO (StablePtr a)@ function
+ converts a value into a stable pointer. It is part of the @PrimIO@
+ monad, because we want to be sure we don't allocate one twice by
+ accident, and then only free one of the copies.
+
+ \begin{verbatim}
+ makeStablePtr# :: a -> State# RealWorld -> (# RealWorld, a #)
+ freeStablePtr# :: StablePtr# a -> State# RealWorld -> 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.
+
+*/
+
+snEntry *stable_ptr_table = NULL;
+static snEntry *stable_ptr_free = NULL;
+
+static unsigned int SPT_size = 0;
+
+#ifdef THREADED_RTS
+static Mutex stable_mutex;
+#endif
+
+/* This hash table maps Haskell objects to stable names, so that every
+ * call to lookupStableName on a given object will return the same
+ * stable name.
+ *
+ * OLD COMMENTS about reference counting follow. The reference count
+ * in a stable name entry is now just a counter.
+ *
+ * Reference counting
+ * ------------------
+ * A plain stable name entry has a zero reference count, which means
+ * the entry will dissappear when the object it points to is
+ * unreachable. For stable pointers, we need an entry that sticks
+ * around and keeps the object it points to alive, so each stable name
+ * entry has an associated reference count.
+ *
+ * A stable pointer has a weighted reference count N attached to it
+ * (actually in its upper 5 bits), which represents the weight
+ * 2^(N-1). The stable name entry keeps a 32-bit reference count, which
+ * represents any weight between 1 and 2^32 (represented as zero).
+ * When the weight is 2^32, the stable name table owns "all" of the
+ * stable pointers to this object, and the entry can be garbage
+ * collected if the object isn't reachable.
+ *
+ * A new stable pointer is given the weight log2(W/2), where W is the
+ * weight stored in the table entry. The new weight in the table is W
+ * - 2^log2(W/2).
+ *
+ * A stable pointer can be "split" into two stable pointers, by
+ * dividing the weight by 2 and giving each pointer half.
+ * When freeing a stable pointer, the weight of the pointer is added
+ * to the weight stored in the table entry.
+ * */
+
+static HashTable *addrToStableHash = NULL;
+
+#define INIT_SPT_SIZE 64
+
+STATIC_INLINE void
+initFreeList(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_ptr_free = table;
+}
+
+void
+initStablePtrTable(void)
+{
+ if (SPT_size > 0)
+ return;
+
+ SPT_size = INIT_SPT_SIZE;
+ stable_ptr_table = stgMallocBytes(SPT_size * sizeof(snEntry),
+ "initStablePtrTable");
+
+ /* 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);
+ addrToStableHash = allocHashTable();
+
+#ifdef THREADED_RTS
+ initMutex(&stable_mutex);
+#endif
+}
+
+/*
+ * get at the real stuff...remove indirections.
+ *
+ * ToDo: move to a better home.
+ */
+static
+StgClosure*
+removeIndirections(StgClosure* p)
+{
+ StgClosure* q = p;
+
+ while (get_itbl(q)->type == IND ||
+ get_itbl(q)->type == IND_STATIC ||
+ get_itbl(q)->type == IND_OLDGEN ||
+ get_itbl(q)->type == IND_PERM ||
+ get_itbl(q)->type == IND_OLDGEN_PERM ) {
+ q = ((StgInd *)q)->indirectee;
+ }
+ return q;
+}
+
+static StgWord
+lookupStableName_(StgPtr p)
+{
+ StgWord sn;
+ void* sn_tmp;
+
+ if (stable_ptr_free == NULL) {
+ enlargeStablePtrTable();
+ }
+
+ /* removing indirections increases the likelihood
+ * of finding a match in the stable name hash table.
+ */
+ p = (StgPtr)removeIndirections((StgClosure*)p);
+
+ sn_tmp = lookupHashTable(addrToStableHash,(W_)p);
+ sn = (StgWord)sn_tmp;
+
+ if (sn != 0) {
+ ASSERT(stable_ptr_table[sn].addr == p);
+ IF_DEBUG(stable,debugBelch("cached stable name %ld at %p\n",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;
+ /* IF_DEBUG(stable,debugBelch("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
+lookupStableName(StgPtr p)
+{
+ StgWord res;
+
+ initStablePtrTable();
+ ACQUIRE_LOCK(&stable_mutex);
+ res = lookupStableName_(p);
+ RELEASE_LOCK(&stable_mutex);
+ return res;
+}
+
+STATIC_INLINE void
+freeStableName(snEntry *sn)
+{
+ ASSERT(sn->sn_obj == NULL);
+ if (sn->addr != NULL) {
+ removeHashTable(addrToStableHash, (W_)sn->addr, NULL);
+ }
+ sn->addr = (P_)stable_ptr_free;
+ stable_ptr_free = sn;
+}
+
+StgStablePtr
+getStablePtr(StgPtr p)
+{
+ StgWord sn;
+
+ initStablePtrTable();
+ ACQUIRE_LOCK(&stable_mutex);
+ sn = lookupStableName_(p);
+ stable_ptr_table[sn].ref++;
+ RELEASE_LOCK(&stable_mutex);
+ return (StgStablePtr)(sn);
+}
+
+void
+freeStablePtr(StgStablePtr sp)
+{
+ snEntry *sn;
+
+ initStablePtrTable();
+ ACQUIRE_LOCK(&stable_mutex);
+
+ sn = &stable_ptr_table[(StgWord)sp];
+
+ ASSERT((StgWord)sp < SPT_size && sn->addr != NULL && sn->ref > 0);
+
+ sn->ref--;
+
+ // 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);
+ }
+
+ RELEASE_LOCK(&stable_mutex);
+}
+
+void
+enlargeStablePtrTable(void)
+{
+ 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");
+
+ initFreeList(stable_ptr_table + old_SPT_size, old_SPT_size, NULL);
+}
+
+/* -----------------------------------------------------------------------------
+ * 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
+markStablePtrTable(evac_fn evac)
+{
+ 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((StgClosure **)&p->addr);
+ }
+ }
+ }
+}
+
+/* -----------------------------------------------------------------------------
+ * 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
+ * collector may move the object it points to.
+ * -------------------------------------------------------------------------- */
+
+void
+threadStablePtrTable( evac_fn evac )
+{
+ 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((StgClosure **)&p->sn_obj);
+ }
+
+ q = p->addr;
+ if (q && (q < (P_)stable_ptr_table || q >= (P_)end_stable_ptr_table)) {
+ evac((StgClosure **)&p->addr);
+ }
+ }
+}
+
+/* -----------------------------------------------------------------------------
+ * Garbage collect any dead entries in the stable pointer table.
+ *
+ * A dead entry has:
+ *
+ * - a zero reference count
+ * - a dead sn_obj
+ *
+ * Both of these conditions must be true in order to re-use the stable
+ * name table entry. We can re-use stable name table entries for live
+ * heap objects, as long as the program has no StableName objects that
+ * refer to the entry.
+ * -------------------------------------------------------------------------- */
+
+void
+gcStablePtrTable( 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);
+ IF_DEBUG(stable, debugBelch("GC'd Stable name %ld\n",
+ p - stable_ptr_table));
+ continue;
+
+ } else {
+ p->addr = (StgPtr)isAlive((StgClosure *)p->addr);
+ IF_DEBUG(stable, debugBelch("Stable name %ld still alive at %p, ref %ld\n", p - stable_ptr_table, p->addr, p->ref));
+ }
+ }
+ }
+ }
+}
+
+/* -----------------------------------------------------------------------------
+ * Update the StablePtr/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
+ * a new one. For a minor collection, we just re-hash the elements
+ * that changed.
+ * -------------------------------------------------------------------------- */
+
+void
+updateStablePtrTable(rtsBool full)
+{
+ snEntry *p, *end_stable_ptr_table;
+
+ if (full && addrToStableHash != NULL) {
+ 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));
+ }
+ }
+ }
+}
projects / ghc-hetmet.git / blobdiff