ghc/rts/Stable.c

   1 /* -----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team, 1998-2002
   4  *
   5  * Stable names and stable pointers.
   6  *
   7  * ---------------------------------------------------------------------------*/
   8
   9 // Make static versions of inline functions in Stable.h:
  10 #define RTS_STABLE_C
  11
  12 #include "PosixSource.h"
  13 #include "Rts.h"
  14 #include "Hash.h"
  15 #include "RtsUtils.h"
  16 #include "OSThreads.h"
  17 #include "Storage.h"
  18 #include "RtsAPI.h"
  19 #include "RtsFlags.h"
  20 #include "OSThreads.h"
  21
  22 /* Comment from ADR's implementation in old RTS:
  23
  24   This files (together with @ghc/runtime/storage/PerformIO.lhc@ and a
  25   small change in @HpOverflow.lc@) consists of the changes in the
  26   runtime system required to implement "Stable Pointers". But we're
  27   getting a bit ahead of ourselves --- what is a stable pointer and what
  28   is it used for?
  29
  30   When Haskell calls C, it normally just passes over primitive integers,
  31   floats, bools, strings, etc.  This doesn't cause any problems at all
  32   for garbage collection because the act of passing them makes a copy
  33   from the heap, stack or wherever they are onto the C-world stack.
  34   However, if we were to pass a heap object such as a (Haskell) @String@
  35   and a garbage collection occured before we finished using it, we'd run
  36   into problems since the heap object might have been moved or even
  37   deleted.
  38
  39   So, if a C call is able to cause a garbage collection or we want to
  40   store a pointer to a heap object between C calls, we must be careful
  41   when passing heap objects. Our solution is to keep a table of all
  42   objects we've given to the C-world and to make sure that the garbage
  43   collector collects these objects --- updating the table as required to
  44   make sure we can still find the object.
  45
  46
  47   Of course, all this rather begs the question: why would we want to
  48   pass a boxed value?
  49
  50   One very good reason is to preserve laziness across the language
  51   interface. Rather than evaluating an integer or a string because it
  52   {\em might\/} be required by the C function, we can wait until the C
  53   function actually wants the value and then force an evaluation.
  54
  55   Another very good reason (the motivating reason!) is that the C code
  56   might want to execute an object of sort $IO ()$ for the side-effects
  57   it will produce. For example, this is used when interfacing to an X
  58   widgets library to allow a direct implementation of callbacks.
  59
  60
  61   The @makeStablePointer :: a -> IO (StablePtr a)@ function
  62   converts a value into a stable pointer.  It is part of the @PrimIO@
  63   monad, because we want to be sure we don't allocate one twice by
  64   accident, and then only free one of the copies.
  65
  66   \begin{verbatim}
  67   makeStablePtr#  :: a -> State# RealWorld -> (# RealWorld, a #)
  68   freeStablePtr#  :: StablePtr# a -> State# RealWorld -> State# RealWorld
  69   deRefStablePtr# :: StablePtr# a -> State# RealWorld ->
  70         (# State# RealWorld, a #)
  71   \end{verbatim}
  72
  73   There may be additional functions on the C side to allow evaluation,
  74   application, etc of a stable pointer.
  75
  76 */
  77
  78 snEntry *stable_ptr_table = NULL;
  79 static snEntry *stable_ptr_free = NULL;
  80
  81 static unsigned int SPT_size = 0;
  82
  83 #ifdef THREADED_RTS
  84 static Mutex stable_mutex;
  85 #endif
  86
  87 /* This hash table maps Haskell objects to stable names, so that every
  88  * call to lookupStableName on a given object will return the same
  89  * stable name.
  90  *
  91  * OLD COMMENTS about reference counting follow.  The reference count
  92  * in a stable name entry is now just a counter.
  93  *
  94  * Reference counting
  95  * ------------------
  96  * A plain stable name entry has a zero reference count, which means
  97  * the entry will dissappear when the object it points to is
  98  * unreachable.  For stable pointers, we need an entry that sticks
  99  * around and keeps the object it points to alive, so each stable name
 100  * entry has an associated reference count.
 101  *
 102  * A stable pointer has a weighted reference count N attached to it
 103  * (actually in its upper 5 bits), which represents the weight
 104  * 2^(N-1).  The stable name entry keeps a 32-bit reference count, which
 105  * represents any weight between 1 and 2^32 (represented as zero).
 106  * When the weight is 2^32, the stable name table owns "all" of the
 107  * stable pointers to this object, and the entry can be garbage
 108  * collected if the object isn't reachable.
 109  *
 110  * A new stable pointer is given the weight log2(W/2), where W is the
 111  * weight stored in the table entry.  The new weight in the table is W
 112  * - 2^log2(W/2).
 113  *
 114  * A stable pointer can be "split" into two stable pointers, by
 115  * dividing the weight by 2 and giving each pointer half.
 116  * When freeing a stable pointer, the weight of the pointer is added
 117  * to the weight stored in the table entry.
 118  * */
 119
 120 static HashTable *addrToStableHash = NULL;
 121
 122 #define INIT_SPT_SIZE 64
 123
 124 STATIC_INLINE void
 125 initFreeList(snEntry *table, nat n, snEntry *free)
 126 {
 127   snEntry *p;
 128
 129   for (p = table + n - 1; p >= table; p--) {
 130     p->addr   = (P_)free;
 131     p->old    = NULL;
 132     p->ref    = 0;
 133     p->sn_obj = NULL;
 134     free = p;
 135   }
 136   stable_ptr_free = table;
 137 }
 138
 139 void
 140 initStablePtrTable(void)
 141 {
 142     // Nothing to do:
 143     // the table will be allocated the first time makeStablePtr is
 144     // called, and we want the table to persist through multiple inits.
 145     //
 146     // Also, getStablePtr is now called from __attribute__((constructor))
 147     // functions, so initialising things here wouldn't work anyway.
 148 #ifdef THREADED_RTS
 149     initMutex(&stable_mutex);
 150 #endif
 151 }
 152
 153 /*
 154  * get at the real stuff...remove indirections.
 155  *
 156  * ToDo: move to a better home.
 157  */
 158 static
 159 StgClosure*
 160 removeIndirections(StgClosure* p)
 161 {
 162   StgClosure* q = p;
 163
 164   while (get_itbl(q)->type == IND ||
 165          get_itbl(q)->type == IND_STATIC ||
 166          get_itbl(q)->type == IND_OLDGEN ||
 167          get_itbl(q)->type == IND_PERM ||
 168          get_itbl(q)->type == IND_OLDGEN_PERM ) {
 169       q = ((StgInd *)q)->indirectee;
 170   }
 171   return q;
 172 }
 173
 174 static StgWord
 175 lookupStableName_(StgPtr p)
 176 {
 177   StgWord sn;
 178   void* sn_tmp;
 179
 180   if (stable_ptr_free == NULL) {
 181     enlargeStablePtrTable();
 182   }
 183
 184   /* removing indirections increases the likelihood
 185    * of finding a match in the stable name hash table.
 186    */
 187   p = (StgPtr)removeIndirections((StgClosure*)p);
 188
 189   sn_tmp = lookupHashTable(addrToStableHash,(W_)p);
 190   sn = (StgWord)sn_tmp;
 191
 192   if (sn != 0) {
 193     ASSERT(stable_ptr_table[sn].addr == p);
 194     IF_DEBUG(stable,debugBelch("cached stable name %ld at %p\n",sn,p));
 195     RELEASE_LOCK(&stable_mutex);
 196     return sn;
 197   } else {
 198     sn = stable_ptr_free - stable_ptr_table;
 199     stable_ptr_free  = (snEntry*)(stable_ptr_free->addr);
 200     stable_ptr_table[sn].ref = 0;
 201     stable_ptr_table[sn].addr = p;
 202     stable_ptr_table[sn].sn_obj = NULL;
 203     /* IF_DEBUG(stable,debugBelch("new stable name %d at %p\n",sn,p)); */
 204
 205     /* add the new stable name to the hash table */
 206     insertHashTable(addrToStableHash, (W_)p, (void *)sn);
 207
 208     return sn;
 209   }
 210 }
 211
 212 StgWord
 213 lookupStableName(StgPtr p)
 214 {
 215     StgWord res;
 216     ACQUIRE_LOCK(&stable_mutex);
 217     res = lookupStableName_(p);
 218     RELEASE_LOCK(&stable_mutex);
 219     return res;
 220 }
 221
 222 STATIC_INLINE void
 223 freeStableName(snEntry *sn)
 224 {
 225   ASSERT(sn->sn_obj == NULL);
 226   if (sn->addr != NULL) {
 227       removeHashTable(addrToStableHash, (W_)sn->addr, NULL);
 228   }
 229   sn->addr = (P_)stable_ptr_free;
 230   stable_ptr_free = sn;
 231 }
 232
 233 StgStablePtr
 234 getStablePtr(StgPtr p)
 235 {
 236   StgWord sn;
 237
 238   ACQUIRE_LOCK(&stable_mutex);
 239   sn = lookupStableName_(p);
 240   stable_ptr_table[sn].ref++;
 241   RELEASE_LOCK(&stable_mutex);
 242   return (StgStablePtr)(sn);
 243 }
 244
 245 void
 246 freeStablePtr(StgStablePtr sp)
 247 {
 248     snEntry *sn;
 249
 250     ACQUIRE_LOCK(&stable_mutex);
 251
 252     sn = &stable_ptr_table[(StgWord)sp];
 253
 254     ASSERT((StgWord)sp < SPT_size  &&  sn->addr != NULL  &&  sn->ref > 0);
 255
 256     sn->ref--;
 257
 258     // If this entry has no StableName attached, then just free it
 259     // immediately.  This is important; it might be a while before the
 260     // next major GC which actually collects the entry.
 261     if (sn->sn_obj == NULL && sn->ref == 0) {
 262         freeStableName(sn);
 263     }
 264
 265     RELEASE_LOCK(&stable_mutex);
 266 }
 267
 268 void
 269 enlargeStablePtrTable(void)
 270 {
 271   nat old_SPT_size = SPT_size;
 272
 273   if (SPT_size == 0) {
 274     // 1st time
 275     SPT_size = INIT_SPT_SIZE;
 276     stable_ptr_table = stgMallocBytes(SPT_size * sizeof(snEntry),
 277                                       "enlargeStablePtrTable");
 278
 279     /* we don't use index 0 in the stable name table, because that
 280      * would conflict with the hash table lookup operations which
 281      * return NULL if an entry isn't found in the hash table.
 282      */
 283     initFreeList(stable_ptr_table+1,INIT_SPT_SIZE-1,NULL);
 284     addrToStableHash = allocHashTable();
 285   }
 286   else {
 287     // 2nd and subsequent times
 288     SPT_size *= 2;
 289     stable_ptr_table =
 290       stgReallocBytes(stable_ptr_table,
 291                       SPT_size * sizeof(snEntry),
 292                       "enlargeStablePtrTable");
 293
 294     initFreeList(stable_ptr_table + old_SPT_size, old_SPT_size, NULL);
 295   }
 296 }
 297
 298 /* -----------------------------------------------------------------------------
 299  * Treat stable pointers as roots for the garbage collector.
 300  *
 301  * A stable pointer is any stable name entry with a ref > 0.  We'll
 302  * take the opportunity to zero the "keep" flags at the same time.
 303  * -------------------------------------------------------------------------- */
 304
 305 void
 306 markStablePtrTable(evac_fn evac)
 307 {
 308     snEntry *p, *end_stable_ptr_table;
 309     StgPtr q;
 310
 311     end_stable_ptr_table = &stable_ptr_table[SPT_size];
 312
 313     // Mark all the stable *pointers* (not stable names).
 314     // _starting_ at index 1; index 0 is unused.
 315     for (p = stable_ptr_table+1; p < end_stable_ptr_table; p++) {
 316         q = p->addr;
 317
 318         // Internal pointers are free slots.  If q == NULL, it's a
 319         // stable name where the object has been GC'd, but the
 320         // StableName object (sn_obj) is still alive.
 321         if (q && (q < (P_)stable_ptr_table || q >= (P_)end_stable_ptr_table)) {
 322
 323             // save the current addr away: we need to be able to tell
 324             // whether the objects moved in order to be able to update
 325             // the hash table later.
 326             p->old = p->addr;
 327
 328             // if the ref is non-zero, treat addr as a root
 329             if (p->ref != 0) {
 330                 evac((StgClosure **)&p->addr);
 331             }
 332         }
 333     }
 334 }
 335
 336 /* -----------------------------------------------------------------------------
 337  * Thread the stable pointer table for compacting GC.
 338  *
 339  * Here we must call the supplied evac function for each pointer into
 340  * the heap from the stable pointer table, because the compacting
 341  * collector may move the object it points to.
 342  * -------------------------------------------------------------------------- */
 343
 344 void
 345 threadStablePtrTable( evac_fn evac )
 346 {
 347     snEntry *p, *end_stable_ptr_table;
 348     StgPtr q;
 349
 350     end_stable_ptr_table = &stable_ptr_table[SPT_size];
 351
 352     for (p = stable_ptr_table+1; p < end_stable_ptr_table; p++) {
 353
 354         if (p->sn_obj != NULL) {
 355             evac((StgClosure **)&p->sn_obj);
 356         }
 357
 358         q = p->addr;
 359         if (q && (q < (P_)stable_ptr_table || q >= (P_)end_stable_ptr_table)) {
 360             evac((StgClosure **)&p->addr);
 361         }
 362     }
 363 }
 364
 365 /* -----------------------------------------------------------------------------
 366  * Garbage collect any dead entries in the stable pointer table.
 367  *
 368  * A dead entry has:
 369  *
 370  *          - a zero reference count
 371  *          - a dead sn_obj
 372  *
 373  * Both of these conditions must be true in order to re-use the stable
 374  * name table entry.  We can re-use stable name table entries for live
 375  * heap objects, as long as the program has no StableName objects that
 376  * refer to the entry.
 377  * -------------------------------------------------------------------------- */
 378
 379 void
 380 gcStablePtrTable( void )
 381 {
 382     snEntry *p, *end_stable_ptr_table;
 383     StgPtr q;
 384
 385     end_stable_ptr_table = &stable_ptr_table[SPT_size];
 386
 387     // NOTE: _starting_ at index 1; index 0 is unused.
 388     for (p = stable_ptr_table + 1; p < end_stable_ptr_table; p++) {
 389
 390         // Update the pointer to the StableName object, if there is one
 391         if (p->sn_obj != NULL) {
 392             p->sn_obj = isAlive(p->sn_obj);
 393         }
 394
 395         // Internal pointers are free slots.  If q == NULL, it's a
 396         // stable name where the object has been GC'd, but the
 397         // StableName object (sn_obj) is still alive.
 398         q = p->addr;
 399         if (q && (q < (P_)stable_ptr_table || q >= (P_)end_stable_ptr_table)) {
 400
 401             // StableNames only:
 402             if (p->ref == 0) {
 403                 if (p->sn_obj == NULL) {
 404                     // StableName object is dead
 405                     freeStableName(p);
 406                     IF_DEBUG(stable, debugBelch("GC'd Stable name %ld\n",
 407                                                 p - stable_ptr_table));
 408                     continue;
 409
 410                 } else {
 411                   p->addr = (StgPtr)isAlive((StgClosure *)p->addr);
 412                     IF_DEBUG(stable, debugBelch("Stable name %ld still alive at %p, ref %ld\n", p - stable_ptr_table, p->addr, p->ref));
 413                 }
 414             }
 415         }
 416     }
 417 }
 418
 419 /* -----------------------------------------------------------------------------
 420  * Update the StablePtr/StableName hash table
 421  *
 422  * The boolean argument 'full' indicates that a major collection is
 423  * being done, so we might as well throw away the hash table and build
 424  * a new one.  For a minor collection, we just re-hash the elements
 425  * that changed.
 426  * -------------------------------------------------------------------------- */
 427
 428 void
 429 updateStablePtrTable(rtsBool full)
 430 {
 431     snEntry *p, *end_stable_ptr_table;
 432
 433     if (full && addrToStableHash != NULL) {
 434         freeHashTable(addrToStableHash,NULL);
 435         addrToStableHash = allocHashTable();
 436     }
 437
 438     end_stable_ptr_table = &stable_ptr_table[SPT_size];
 439
 440     // NOTE: _starting_ at index 1; index 0 is unused.
 441     for (p = stable_ptr_table + 1; p < end_stable_ptr_table; p++) {
 442
 443         if (p->addr == NULL) {
 444             if (p->old != NULL) {
 445                 // The target has been garbage collected.  Remove its
 446                 // entry from the hash table.
 447                 removeHashTable(addrToStableHash, (W_)p->old, NULL);
 448                 p->old = NULL;
 449             }
 450         }
 451         else if (p->addr < (P_)stable_ptr_table
 452                  || p->addr >= (P_)end_stable_ptr_table) {
 453             // Target still alive, Re-hash this stable name
 454             if (full) {
 455                 insertHashTable(addrToStableHash, (W_)p->addr,
 456                                 (void *)(p - stable_ptr_table));
 457             } else if (p->addr != p->old) {
 458                 removeHashTable(addrToStableHash, (W_)p->old, NULL);
 459                 insertHashTable(addrToStableHash, (W_)p->addr,
 460                                 (void *)(p - stable_ptr_table));
 461             }
 462         }
 463     }
 464 }