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