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