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     return sn;
 196   } else {
 197     sn = stable_ptr_free - stable_ptr_table;
 198     stable_ptr_free  = (snEntry*)(stable_ptr_free->addr);
 199     stable_ptr_table[sn].ref = 0;
 200     stable_ptr_table[sn].addr = p;
 201     stable_ptr_table[sn].sn_obj = NULL;
 202     /* IF_DEBUG(stable,debugBelch("new stable name %d at %p\n",sn,p)); */
 203
 204     /* add the new stable name to the hash table */
 205     insertHashTable(addrToStableHash, (W_)p, (void *)sn);
 206
 207     return sn;
 208   }
 209 }
 210
 211 StgWord
 212 lookupStableName(StgPtr p)
 213 {
 214     StgWord res;
 215     ACQUIRE_LOCK(&stable_mutex);
 216     res = lookupStableName_(p);
 217     RELEASE_LOCK(&stable_mutex);
 218     return res;
 219 }
 220
 221 STATIC_INLINE void
 222 freeStableName(snEntry *sn)
 223 {
 224   ASSERT(sn->sn_obj == NULL);
 225   if (sn->addr != NULL) {
 226       removeHashTable(addrToStableHash, (W_)sn->addr, NULL);
 227   }
 228   sn->addr = (P_)stable_ptr_free;
 229   stable_ptr_free = sn;
 230 }
 231
 232 StgStablePtr
 233 getStablePtr(StgPtr p)
 234 {
 235   StgWord sn;
 236
 237   ACQUIRE_LOCK(&stable_mutex);
 238   sn = lookupStableName_(p);
 239   stable_ptr_table[sn].ref++;
 240   RELEASE_LOCK(&stable_mutex);
 241   return (StgStablePtr)(sn);
 242 }
 243
 244 void
 245 freeStablePtr(StgStablePtr sp)
 246 {
 247     snEntry *sn;
 248
 249     ACQUIRE_LOCK(&stable_mutex);
 250
 251     sn = &stable_ptr_table[(StgWord)sp];
 252
 253     ASSERT((StgWord)sp < SPT_size  &&  sn->addr != NULL  &&  sn->ref > 0);
 254
 255     sn->ref--;
 256
 257     // If this entry has no StableName attached, then just free it
 258     // immediately.  This is important; it might be a while before the
 259     // next major GC which actually collects the entry.
 260     if (sn->sn_obj == NULL && sn->ref == 0) {
 261         freeStableName(sn);
 262     }
 263
 264     RELEASE_LOCK(&stable_mutex);
 265 }
 266
 267 void
 268 enlargeStablePtrTable(void)
 269 {
 270   nat old_SPT_size = SPT_size;
 271
 272   if (SPT_size == 0) {
 273     // 1st time
 274     SPT_size = INIT_SPT_SIZE;
 275     stable_ptr_table = stgMallocBytes(SPT_size * sizeof(snEntry),
 276                                       "enlargeStablePtrTable");
 277
 278     /* we don't use index 0 in the stable name table, because that
 279      * would conflict with the hash table lookup operations which
 280      * return NULL if an entry isn't found in the hash table.
 281      */
 282     initFreeList(stable_ptr_table+1,INIT_SPT_SIZE-1,NULL);
 283     addrToStableHash = allocHashTable();
 284   }
 285   else {
 286     // 2nd and subsequent times
 287     SPT_size *= 2;
 288     stable_ptr_table =
 289       stgReallocBytes(stable_ptr_table,
 290                       SPT_size * sizeof(snEntry),
 291                       "enlargeStablePtrTable");
 292
 293     initFreeList(stable_ptr_table + old_SPT_size, old_SPT_size, NULL);
 294   }
 295 }
 296
 297 /* -----------------------------------------------------------------------------
 298  * Treat stable pointers as roots for the garbage collector.
 299  *
 300  * A stable pointer is any stable name entry with a ref > 0.  We'll
 301  * take the opportunity to zero the "keep" flags at the same time.
 302  * -------------------------------------------------------------------------- */
 303
 304 void
 305 markStablePtrTable(evac_fn evac)
 306 {
 307     snEntry *p, *end_stable_ptr_table;
 308     StgPtr q;
 309
 310     end_stable_ptr_table = &stable_ptr_table[SPT_size];
 311
 312     // Mark all the stable *pointers* (not stable names).
 313     // _starting_ at index 1; index 0 is unused.
 314     for (p = stable_ptr_table+1; p < end_stable_ptr_table; p++) {
 315         q = p->addr;
 316
 317         // Internal pointers are free slots.  If q == NULL, it's a
 318         // stable name where the object has been GC'd, but the
 319         // StableName object (sn_obj) is still alive.
 320         if (q && (q < (P_)stable_ptr_table || q >= (P_)end_stable_ptr_table)) {
 321
 322             // save the current addr away: we need to be able to tell
 323             // whether the objects moved in order to be able to update
 324             // the hash table later.
 325             p->old = p->addr;
 326
 327             // if the ref is non-zero, treat addr as a root
 328             if (p->ref != 0) {
 329                 evac((StgClosure **)&p->addr);
 330             }
 331         }
 332     }
 333 }
 334
 335 /* -----------------------------------------------------------------------------
 336  * Thread the stable pointer table for compacting GC.
 337  *
 338  * Here we must call the supplied evac function for each pointer into
 339  * the heap from the stable pointer table, because the compacting
 340  * collector may move the object it points to.
 341  * -------------------------------------------------------------------------- */
 342
 343 void
 344 threadStablePtrTable( evac_fn evac )
 345 {
 346     snEntry *p, *end_stable_ptr_table;
 347     StgPtr q;
 348
 349     end_stable_ptr_table = &stable_ptr_table[SPT_size];
 350
 351     for (p = stable_ptr_table+1; p < end_stable_ptr_table; p++) {
 352
 353         if (p->sn_obj != NULL) {
 354             evac((StgClosure **)&p->sn_obj);
 355         }
 356
 357         q = p->addr;
 358         if (q && (q < (P_)stable_ptr_table || q >= (P_)end_stable_ptr_table)) {
 359             evac((StgClosure **)&p->addr);
 360         }
 361     }
 362 }
 363
 364 /* -----------------------------------------------------------------------------
 365  * Garbage collect any dead entries in the stable pointer table.
 366  *
 367  * A dead entry has:
 368  *
 369  *          - a zero reference count
 370  *          - a dead sn_obj
 371  *
 372  * Both of these conditions must be true in order to re-use the stable
 373  * name table entry.  We can re-use stable name table entries for live
 374  * heap objects, as long as the program has no StableName objects that
 375  * refer to the entry.
 376  * -------------------------------------------------------------------------- */
 377
 378 void
 379 gcStablePtrTable( void )
 380 {
 381     snEntry *p, *end_stable_ptr_table;
 382     StgPtr q;
 383
 384     end_stable_ptr_table = &stable_ptr_table[SPT_size];
 385
 386     // NOTE: _starting_ at index 1; index 0 is unused.
 387     for (p = stable_ptr_table + 1; p < end_stable_ptr_table; p++) {
 388
 389         // Update the pointer to the StableName object, if there is one
 390         if (p->sn_obj != NULL) {
 391             p->sn_obj = isAlive(p->sn_obj);
 392         }
 393
 394         // Internal pointers are free slots.  If q == NULL, it's a
 395         // stable name where the object has been GC'd, but the
 396         // StableName object (sn_obj) is still alive.
 397         q = p->addr;
 398         if (q && (q < (P_)stable_ptr_table || q >= (P_)end_stable_ptr_table)) {
 399
 400             // StableNames only:
 401             if (p->ref == 0) {
 402                 if (p->sn_obj == NULL) {
 403                     // StableName object is dead
 404                     freeStableName(p);
 405                     IF_DEBUG(stable, debugBelch("GC'd Stable name %ld\n",
 406                                                 p - stable_ptr_table));
 407                     continue;
 408
 409                 } else {
 410                   p->addr = (StgPtr)isAlive((StgClosure *)p->addr);
 411                     IF_DEBUG(stable, debugBelch("Stable name %ld still alive at %p, ref %ld\n", p - stable_ptr_table, p->addr, p->ref));
 412                 }
 413             }
 414         }
 415     }
 416 }
 417
 418 /* -----------------------------------------------------------------------------
 419  * Update the StablePtr/StableName hash table
 420  *
 421  * The boolean argument 'full' indicates that a major collection is
 422  * being done, so we might as well throw away the hash table and build
 423  * a new one.  For a minor collection, we just re-hash the elements
 424  * that changed.
 425  * -------------------------------------------------------------------------- */
 426
 427 void
 428 updateStablePtrTable(rtsBool full)
 429 {
 430     snEntry *p, *end_stable_ptr_table;
 431
 432     if (full && addrToStableHash != NULL) {
 433         freeHashTable(addrToStableHash,NULL);
 434         addrToStableHash = allocHashTable();
 435     }
 436
 437     end_stable_ptr_table = &stable_ptr_table[SPT_size];
 438
 439     // NOTE: _starting_ at index 1; index 0 is unused.
 440     for (p = stable_ptr_table + 1; p < end_stable_ptr_table; p++) {
 441
 442         if (p->addr == NULL) {
 443             if (p->old != NULL) {
 444                 // The target has been garbage collected.  Remove its
 445                 // entry from the hash table.
 446                 removeHashTable(addrToStableHash, (W_)p->old, NULL);
 447                 p->old = NULL;
 448             }
 449         }
 450         else if (p->addr < (P_)stable_ptr_table
 451                  || p->addr >= (P_)end_stable_ptr_table) {
 452             // Target still alive, Re-hash this stable name
 453             if (full) {
 454                 insertHashTable(addrToStableHash, (W_)p->addr,
 455                                 (void *)(p - stable_ptr_table));
 456             } else if (p->addr != p->old) {
 457                 removeHashTable(addrToStableHash, (W_)p->old, NULL);
 458                 insertHashTable(addrToStableHash, (W_)p->addr,
 459                                 (void *)(p - stable_ptr_table));
 460             }
 461         }
 462     }
 463 }