rts/Stable.c

   1 /* -*- tab-width: 4 -*- */
   2
   3 /* -----------------------------------------------------------------------------
   4  *
   5  * (c) The GHC Team, 1998-2002
   6  *
   7  * Stable names and stable pointers.
   8  *
   9  * ---------------------------------------------------------------------------*/
  10
  11 #include "PosixSource.h"
  12 #include "Rts.h"
  13 #include "RtsAPI.h"
  14
  15 #include "Hash.h"
  16 #include "RtsUtils.h"
  17 #include "Trace.h"
  18 #include "Stable.h"
  19
  20 /* Comment from ADR's implementation in old RTS:
  21
  22   This files (together with @ghc/runtime/storage/PerformIO.lhc@ and a
  23   small change in @HpOverflow.lc@) consists of the changes in the
  24   runtime system required to implement "Stable Pointers". But we're
  25   getting a bit ahead of ourselves --- what is a stable pointer and what
  26   is it used for?
  27
  28   When Haskell calls C, it normally just passes over primitive integers,
  29   floats, bools, strings, etc.  This doesn't cause any problems at all
  30   for garbage collection because the act of passing them makes a copy
  31   from the heap, stack or wherever they are onto the C-world stack.
  32   However, if we were to pass a heap object such as a (Haskell) @String@
  33   and a garbage collection occured before we finished using it, we'd run
  34   into problems since the heap object might have been moved or even
  35   deleted.
  36
  37   So, if a C call is able to cause a garbage collection or we want to
  38   store a pointer to a heap object between C calls, we must be careful
  39   when passing heap objects. Our solution is to keep a table of all
  40   objects we've given to the C-world and to make sure that the garbage
  41   collector collects these objects --- updating the table as required to
  42   make sure we can still find the object.
  43
  44
  45   Of course, all this rather begs the question: why would we want to
  46   pass a boxed value?
  47
  48   One very good reason is to preserve laziness across the language
  49   interface. Rather than evaluating an integer or a string because it
  50   {\em might\/} be required by the C function, we can wait until the C
  51   function actually wants the value and then force an evaluation.
  52
  53   Another very good reason (the motivating reason!) is that the C code
  54   might want to execute an object of sort $IO ()$ for the side-effects
  55   it will produce. For example, this is used when interfacing to an X
  56   widgets library to allow a direct implementation of callbacks.
  57
  58   One final reason is that we may want to store composite Haskell
  59   values in data structures implemented in the C side. Serializing and
  60   deserializing these structures into unboxed form suitable for C may
  61   be more expensive than maintaining the extra layer of indirection of
  62   stable pointers.
  63
  64   The @makeStablePointer :: a -> IO (StablePtr a)@ function
  65   converts a value into a stable pointer.  It is part of the @PrimIO@
  66   monad, because we want to be sure we don't allocate one twice by
  67   accident, and then only free one of the copies.
  68
  69   \begin{verbatim}
  70   makeStablePtr#  :: a -> State# RealWorld -> (# RealWorld, a #)
  71   freeStablePtr#  :: StablePtr# a -> State# RealWorld -> State# RealWorld
  72   deRefStablePtr# :: StablePtr# a -> State# RealWorld ->
  73         (# State# RealWorld, a #)
  74   \end{verbatim}
  75
  76   There may be additional functions on the C side to allow evaluation,
  77   application, etc of a stable pointer.
  78
  79   Stable Pointers are exported to the outside world as indices and not
  80   pointers, because the stable pointer table is allowed to be
  81   reallocated for growth. The table is never shrunk for its space to
  82   be reclaimed.
  83
  84   Future plans for stable ptrs include distinguishing them by the
  85   generation of the pointed object. See
  86   http://ghc.haskell.org/trac/ghc/ticket/7670 for details.
  87 */
  88
  89 snEntry *stable_name_table = NULL;
  90 static snEntry *stable_name_free = NULL;
  91 static unsigned int SNT_size = 0;
  92 #define INIT_SNT_SIZE 64
  93
  94 spEntry *stable_ptr_table = NULL;
  95 static spEntry *stable_ptr_free = NULL;
  96 static unsigned int SPT_size = 0;
  97 #define INIT_SPT_SIZE 64
  98
  99 #ifdef THREADED_RTS
 100 Mutex stable_mutex;
 101 #endif
 102
 103 static void enlargeStableNameTable(void);
 104 static void enlargeStablePtrTable(void);
 105
 106 /*
 107  * This hash table maps Haskell objects to stable names, so that every
 108  * call to lookupStableName on a given object will return the same
 109  * stable name.
 110  */
 111
 112 static HashTable *addrToStableHash = NULL;
 113
 114 /* -----------------------------------------------------------------------------
 115  * We must lock the StablePtr table during GC, to prevent simultaneous
 116  * calls to freeStablePtr().
 117  * -------------------------------------------------------------------------- */
 118
 119 void
 120 stableLock(void)
 121 {
 122     initStableTables();
 123     ACQUIRE_LOCK(&stable_mutex);
 124 }
 125
 126 void
 127 stableUnlock(void)
 128 {
 129     RELEASE_LOCK(&stable_mutex);
 130 }
 131
 132 /* -----------------------------------------------------------------------------
 133  * Initialising the tables
 134  * -------------------------------------------------------------------------- */
 135
 136 STATIC_INLINE void
 137 initSnEntryFreeList(snEntry *table, nat n, snEntry *free)
 138 {
 139   snEntry *p;
 140   for (p = table + n - 1; p >= table; p--) {
 141     p->addr   = (P_)free;
 142     p->old    = NULL;
 143     p->sn_obj = NULL;
 144     free = p;
 145   }
 146   stable_name_free = table;
 147 }
 148
 149 STATIC_INLINE void
 150 initSpEntryFreeList(spEntry *table, nat n, spEntry *free)
 151 {
 152   spEntry *p;
 153   for (p = table + n - 1; p >= table; p--) {
 154       p->addr = (P_)free;
 155       free = p;
 156   }
 157   stable_ptr_free = table;
 158 }
 159
 160 void
 161 initStableTables(void)
 162 {
 163     if (SNT_size > 0) return;
 164     SNT_size = INIT_SNT_SIZE;
 165     stable_name_table = stgMallocBytes(SNT_size * sizeof *stable_name_table,
 166                                        "initStableNameTable");
 167     /* we don't use index 0 in the stable name table, because that
 168      * would conflict with the hash table lookup operations which
 169      * return NULL if an entry isn't found in the hash table.
 170      */
 171     initSnEntryFreeList(stable_name_table + 1,INIT_SNT_SIZE-1,NULL);
 172     addrToStableHash = allocHashTable();
 173
 174     if (SPT_size > 0) return;
 175     SPT_size = INIT_SPT_SIZE;
 176     stable_ptr_table = stgMallocBytes(SPT_size * sizeof *stable_ptr_table,
 177                                       "initStablePtrTable");
 178     initSpEntryFreeList(stable_ptr_table,INIT_SPT_SIZE,NULL);
 179
 180 #ifdef THREADED_RTS
 181     initMutex(&stable_mutex);
 182 #endif
 183 }
 184
 185 /* -----------------------------------------------------------------------------
 186  * Enlarging the tables
 187  * -------------------------------------------------------------------------- */
 188
 189 static void
 190 enlargeStableNameTable(void)
 191 {
 192     nat old_SNT_size = SNT_size;
 193
 194     // 2nd and subsequent times
 195     SNT_size *= 2;
 196     stable_name_table =
 197         stgReallocBytes(stable_name_table,
 198                         SNT_size * sizeof *stable_name_table,
 199                         "enlargeStableNameTable");
 200
 201     initSnEntryFreeList(stable_name_table + old_SNT_size, old_SNT_size, NULL);
 202 }
 203
 204 static void
 205 enlargeStablePtrTable(void)
 206 {
 207     nat old_SPT_size = SPT_size;
 208
 209     // 2nd and subsequent times
 210     SPT_size *= 2;
 211     stable_ptr_table =
 212         stgReallocBytes(stable_ptr_table,
 213                         SPT_size * sizeof *stable_ptr_table,
 214                         "enlargeStablePtrTable");
 215
 216     initSpEntryFreeList(stable_ptr_table + old_SPT_size, old_SPT_size, NULL);
 217 }
 218
 219 /* -----------------------------------------------------------------------------
 220  * Freeing entries and tables
 221  * -------------------------------------------------------------------------- */
 222
 223 void
 224 exitStableTables(void)
 225 {
 226     if (addrToStableHash)
 227         freeHashTable(addrToStableHash, NULL);
 228     addrToStableHash = NULL;
 229
 230     if (stable_name_table)
 231         stgFree(stable_name_table);
 232     stable_name_table = NULL;
 233     SNT_size = 0;
 234
 235     if (stable_ptr_table)
 236         stgFree(stable_ptr_table);
 237     stable_ptr_table = NULL;
 238     SPT_size = 0;
 239
 240 #ifdef THREADED_RTS
 241     closeMutex(&stable_mutex);
 242 #endif
 243 }
 244
 245 STATIC_INLINE void
 246 freeSnEntry(snEntry *sn)
 247 {
 248   ASSERT(sn->sn_obj == NULL);
 249   removeHashTable(addrToStableHash, (W_)sn->old, NULL);
 250   sn->addr = (P_)stable_name_free;
 251   stable_name_free = sn;
 252 }
 253
 254 STATIC_INLINE void
 255 freeSpEntry(spEntry *sp)
 256 {
 257     sp->addr = (P_)stable_ptr_free;
 258     stable_ptr_free = sp;
 259 }
 260
 261 void
 262 freeStablePtrUnsafe(StgStablePtr sp)
 263 {
 264     ASSERT((StgWord)sp < SPT_size);
 265     freeSpEntry(&stable_ptr_table[(StgWord)sp]);
 266 }
 267
 268 void
 269 freeStablePtr(StgStablePtr sp)
 270 {
 271     stableLock();
 272     freeStablePtrUnsafe(sp);
 273     stableUnlock();
 274 }
 275
 276 /* -----------------------------------------------------------------------------
 277  * Looking up
 278  * -------------------------------------------------------------------------- */
 279
 280 /*
 281  * get at the real stuff...remove indirections.
 282  */
 283 static StgClosure*
 284 removeIndirections (StgClosure* p)
 285 {
 286     StgClosure* q;
 287
 288     while (1)
 289     {
 290         q = UNTAG_CLOSURE(p);
 291
 292         switch (get_itbl(q)->type) {
 293         case IND:
 294         case IND_STATIC:
 295         case IND_PERM:
 296             p = ((StgInd *)q)->indirectee;
 297             continue;
 298
 299         case BLACKHOLE:
 300             p = ((StgInd *)q)->indirectee;
 301             if (GET_CLOSURE_TAG(p) != 0) {
 302                 continue;
 303             } else {
 304                 break;
 305             }
 306
 307         default:
 308             break;
 309         }
 310         return p;
 311     }
 312 }
 313
 314 StgWord
 315 lookupStableName (StgPtr p)
 316 {
 317   StgWord sn;
 318   void* sn_tmp;
 319
 320   stableLock();
 321
 322   if (stable_name_free == NULL) {
 323     enlargeStableNameTable();
 324   }
 325
 326   /* removing indirections increases the likelihood
 327    * of finding a match in the stable name hash table.
 328    */
 329   p = (StgPtr)removeIndirections((StgClosure*)p);
 330
 331   // register the untagged pointer.  This just makes things simpler.
 332   p = (StgPtr)UNTAG_CLOSURE((StgClosure*)p);
 333
 334   sn_tmp = lookupHashTable(addrToStableHash,(W_)p);
 335   sn = (StgWord)sn_tmp;
 336
 337   if (sn != 0) {
 338     ASSERT(stable_name_table[sn].addr == p);
 339     debugTrace(DEBUG_stable, "cached stable name %ld at %p",sn,p);
 340     stableUnlock();
 341     return sn;
 342   }
 343
 344   sn = stable_name_free - stable_name_table;
 345   stable_name_free  = (snEntry*)(stable_name_free->addr);
 346   stable_name_table[sn].addr = p;
 347   stable_name_table[sn].sn_obj = NULL;
 348   /* debugTrace(DEBUG_stable, "new stable name %d at %p\n",sn,p); */
 349
 350   /* add the new stable name to the hash table */
 351   insertHashTable(addrToStableHash, (W_)p, (void *)sn);
 352
 353   stableUnlock();
 354
 355   return sn;
 356 }
 357
 358 StgStablePtr
 359 getStablePtr(StgPtr p)
 360 {
 361   StgWord sp;
 362
 363   stableLock();
 364   if (!stable_ptr_free) enlargeStablePtrTable();
 365   sp = stable_ptr_free - stable_ptr_table;
 366   stable_ptr_free  = (spEntry*)(stable_ptr_free->addr);
 367   stable_ptr_table[sp].addr = p;
 368   stableUnlock();
 369   return (StgStablePtr)(sp);
 370 }
 371
 372 /* -----------------------------------------------------------------------------
 373  * Treat stable pointers as roots for the garbage collector.
 374  * -------------------------------------------------------------------------- */
 375
 376 #define FOR_EACH_STABLE_PTR(p, CODE)                                    \
 377     do {                                                                \
 378         spEntry *p;                                                     \
 379         spEntry *__end_ptr = &stable_ptr_table[SPT_size];               \
 380         for (p = stable_ptr_table; p < __end_ptr; p++) {                \
 381             /* Internal pointers are free slots. NULL is last in free */ \
 382             /* list. */                                                 \
 383             if (p->addr &&                                              \
 384                 (p->addr < (P_)stable_ptr_table || p->addr >= (P_)__end_ptr)) \
 385             {                                                           \
 386                 do { CODE } while(0);                                   \
 387             }                                                           \
 388         }                                                               \
 389     } while(0)
 390
 391 #define FOR_EACH_STABLE_NAME(p, CODE)                                   \
 392     do {                                                                \
 393         snEntry *p;                                                     \
 394         snEntry *__end_ptr = &stable_name_table[SNT_size];              \
 395         for (p = stable_name_table + 1; p < __end_ptr; p++) {           \
 396             /* Internal pointers are free slots.  */                    \
 397             /* If p->addr == NULL, it's a */                            \
 398             /* stable name where the object has been GC'd, but the */   \
 399             /* StableName object (sn_obj) is still alive. */            \
 400             if ((p->addr < (P_)stable_name_table ||                     \
 401                  p->addr >= (P_)__end_ptr))                             \
 402             {                                                           \
 403                 /* NOTE: There is an ambiguity here if p->addr == NULL */ \
 404                 /* it is either the last item in the free list or it */ \
 405                 /* is a stable name whose pointee died. sn_obj == NULL */ \
 406                 /* disambiguates as last free list item. */             \
 407                 do { CODE } while(0);                                   \
 408             }                                                           \
 409         }                                                               \
 410     } while(0)
 411
 412 STATIC_INLINE void
 413 markStablePtrTable(evac_fn evac, void *user)
 414 {
 415     FOR_EACH_STABLE_PTR(p, evac(user, (StgClosure **)&p->addr););
 416 }
 417
 418 STATIC_INLINE void
 419 rememberOldStableNameAddresses(void)
 420 {
 421     /* TODO: Only if !full GC */
 422     FOR_EACH_STABLE_NAME(p, p->old = p->addr;);
 423 }
 424
 425 void
 426 markStableTables(evac_fn evac, void *user)
 427 {
 428     markStablePtrTable(evac, user);
 429     rememberOldStableNameAddresses();
 430 }
 431
 432 /* -----------------------------------------------------------------------------
 433  * Thread the stable pointer table for compacting GC.
 434  *
 435  * Here we must call the supplied evac function for each pointer into
 436  * the heap from the stable tables, because the compacting
 437  * collector may move the object it points to.
 438  * -------------------------------------------------------------------------- */
 439
 440 STATIC_INLINE void
 441 threadStableNameTable( evac_fn evac, void *user )
 442 {
 443     FOR_EACH_STABLE_NAME(p, {
 444         if (p->sn_obj != NULL) {
 445             evac(user, (StgClosure **)&p->sn_obj);
 446         }
 447         if (p->addr != NULL) {
 448             evac(user, (StgClosure **)&p->addr);
 449         }
 450     });
 451 }
 452
 453 STATIC_INLINE void
 454 threadStablePtrTable( evac_fn evac, void *user )
 455 {
 456     FOR_EACH_STABLE_PTR(p, evac(user, (StgClosure **)&p->addr););
 457 }
 458
 459 void
 460 threadStableTables( evac_fn evac, void *user )
 461 {
 462     threadStableNameTable(evac, user);
 463     threadStablePtrTable(evac, user);
 464 }
 465
 466 /* -----------------------------------------------------------------------------
 467  * Garbage collect any dead entries in the stable pointer table.
 468  *
 469  * A dead entry has:
 470  *
 471  *          - a zero reference count
 472  *          - a dead sn_obj
 473  *
 474  * Both of these conditions must be true in order to re-use the stable
 475  * name table entry.  We can re-use stable name table entries for live
 476  * heap objects, as long as the program has no StableName objects that
 477  * refer to the entry.
 478  * -------------------------------------------------------------------------- */
 479
 480 void
 481 gcStableTables( void )
 482 {
 483     FOR_EACH_STABLE_NAME(
 484         p, {
 485             // Update the pointer to the StableName object, if there is one
 486             if (p->sn_obj != NULL) {
 487                 p->sn_obj = isAlive(p->sn_obj);
 488                 if(p->sn_obj == NULL) {
 489                     // StableName object died
 490                     debugTrace(DEBUG_stable, "GC'd StableName %ld (addr=%p)",
 491                                (long)(p - stable_name_table), p->addr);
 492                     freeSnEntry(p);
 493                     /* Can't "continue", so use goto */
 494                     goto next_stable_name;
 495                 }
 496             }
 497             /* If sn_obj became NULL, the object died, and addr is now
 498              * invalid. But if sn_obj was null, then the StableName
 499              * object may not have been created yet, while the pointee
 500              * already exists and must be updated to new location. */
 501             if (p->addr != NULL) {
 502                 p->addr = (StgPtr)isAlive((StgClosure *)p->addr);
 503                 if(p->addr == NULL) {
 504                     // StableName pointee died
 505                     debugTrace(DEBUG_stable, "GC'd pointee %ld",
 506                                (long)(p - stable_name_table));
 507                 }
 508             }
 509     next_stable_name:
 510             if (0) {}
 511         });
 512 }
 513
 514 /* -----------------------------------------------------------------------------
 515  * Update the StableName hash table
 516  *
 517  * The boolean argument 'full' indicates that a major collection is
 518  * being done, so we might as well throw away the hash table and build
 519  * a new one.  For a minor collection, we just re-hash the elements
 520  * that changed.
 521  * -------------------------------------------------------------------------- */
 522
 523 void
 524 updateStableTables(rtsBool full)
 525 {
 526     if (full && addrToStableHash != NULL && 0 != keyCountHashTable(addrToStableHash)) {
 527         freeHashTable(addrToStableHash,NULL);
 528         addrToStableHash = allocHashTable();
 529     }
 530
 531     if(full) {
 532         FOR_EACH_STABLE_NAME(
 533             p, {
 534                 if (p->addr != NULL) {
 535                     // Target still alive, Re-hash this stable name
 536                     insertHashTable(addrToStableHash, (W_)p->addr, (void *)(p - stable_name_table));
 537                 }
 538             });
 539     } else {
 540         FOR_EACH_STABLE_NAME(
 541             p, {
 542                 if (p->addr != p->old) {
 543                     removeHashTable(addrToStableHash, (W_)p->old, NULL);
 544                     /* Movement happened: */
 545                     if (p->addr != NULL) {
 546                         insertHashTable(addrToStableHash, (W_)p->addr, (void *)(p - stable_name_table));
 547                     }
 548                 }
 549             });
 550     }
 551 }