Stable.c 18.3 KB
Newer Older
1 2
/* -*- tab-width: 4 -*- */

3 4
/* -----------------------------------------------------------------------------
 *
5
 * (c) The GHC Team, 1998-2002
6 7 8 9 10
 *
 * Stable names and stable pointers.
 *
 * ---------------------------------------------------------------------------*/

11
#include "PosixSource.h"
12
#include "Rts.h"
Simon Marlow's avatar
Simon Marlow committed
13 14
#include "RtsAPI.h"

15 16
#include "Hash.h"
#include "RtsUtils.h"
Simon Marlow's avatar
Simon Marlow committed
17
#include "Trace.h"
18
#include "Stable.h"
19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57

/* Comment from ADR's implementation in old RTS:

  This files (together with @ghc/runtime/storage/PerformIO.lhc@ and a
  small change in @HpOverflow.lc@) consists of the changes in the
  runtime system required to implement "Stable Pointers". But we're
  getting a bit ahead of ourselves --- what is a stable pointer and what
  is it used for?

  When Haskell calls C, it normally just passes over primitive integers,
  floats, bools, strings, etc.  This doesn't cause any problems at all
  for garbage collection because the act of passing them makes a copy
  from the heap, stack or wherever they are onto the C-world stack.
  However, if we were to pass a heap object such as a (Haskell) @String@
  and a garbage collection occured before we finished using it, we'd run
  into problems since the heap object might have been moved or even
  deleted.

  So, if a C call is able to cause a garbage collection or we want to
  store a pointer to a heap object between C calls, we must be careful
  when passing heap objects. Our solution is to keep a table of all
  objects we've given to the C-world and to make sure that the garbage
  collector collects these objects --- updating the table as required to
  make sure we can still find the object.


  Of course, all this rather begs the question: why would we want to
  pass a boxed value?

  One very good reason is to preserve laziness across the language
  interface. Rather than evaluating an integer or a string because it
  {\em might\/} be required by the C function, we can wait until the C
  function actually wants the value and then force an evaluation.

  Another very good reason (the motivating reason!) is that the C code
  might want to execute an object of sort $IO ()$ for the side-effects
  it will produce. For example, this is used when interfacing to an X
  widgets library to allow a direct implementation of callbacks.

58 59 60 61 62
  One final reason is that we may want to store composite Haskell
  values in data structures implemented in the C side. Serializing and
  deserializing these structures into unboxed form suitable for C may
  be more expensive than maintaining the extra layer of indirection of
  stable pointers.
63 64 65 66 67 68 69 70 71

  The @makeStablePointer :: a -> IO (StablePtr a)@ function
  converts a value into a stable pointer.  It is part of the @PrimIO@
  monad, because we want to be sure we don't allocate one twice by
  accident, and then only free one of the copies.

  \begin{verbatim}
  makeStablePtr#  :: a -> State# RealWorld -> (# RealWorld, a #)
  freeStablePtr#  :: StablePtr# a -> State# RealWorld -> State# RealWorld
72
  deRefStablePtr# :: StablePtr# a -> State# RealWorld ->
73 74 75 76 77 78
        (# State# RealWorld, a #)
  \end{verbatim}

  There may be additional functions on the C side to allow evaluation,
  application, etc of a stable pointer.

79 80 81 82 83 84 85 86
  Stable Pointers are exported to the outside world as indices and not
  pointers, because the stable pointer table is allowed to be
  reallocated for growth. The table is never shrunk for its space to
  be reclaimed.

  Future plans for stable ptrs include distinguishing them by the
  generation of the pointed object. See
  http://hackage.haskell.org/trac/ghc/ticket/7670 for details.
87 88
*/

89 90 91 92
snEntry *stable_name_table = NULL;
static snEntry *stable_name_free = NULL;
static unsigned int SNT_size = 0;
#define INIT_SNT_SIZE 64
93

94 95
spEntry *stable_ptr_table = NULL;
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);
Simon Marlow's avatar
Simon Marlow committed
104 105
static void enlargeStablePtrTable(void);

106 107 108 109
/* This hash table maps Haskell objects to stable names, so that every
 * call to lookupStableName on a given object will return the same
 * stable name.
 *
110 111 112
 * OLD COMMENTS about reference counting follow.  The reference count
 * in a stable name entry is now just a counter.
 *
113 114 115 116 117 118 119 120 121 122
 * Reference counting
 * ------------------
 * A plain stable name entry has a zero reference count, which means
 * the entry will dissappear when the object it points to is
 * unreachable.  For stable pointers, we need an entry that sticks
 * around and keeps the object it points to alive, so each stable name
 * entry has an associated reference count.
 *
 * A stable pointer has a weighted reference count N attached to it
 * (actually in its upper 5 bits), which represents the weight
123
 * 2^(N-1).  The stable name entry keeps a 32-bit reference count, which
124 125 126 127 128 129 130 131 132 133 134 135 136 137 138
 * represents any weight between 1 and 2^32 (represented as zero).
 * When the weight is 2^32, the stable name table owns "all" of the
 * stable pointers to this object, and the entry can be garbage
 * collected if the object isn't reachable.
 *
 * A new stable pointer is given the weight log2(W/2), where W is the
 * weight stored in the table entry.  The new weight in the table is W
 * - 2^log2(W/2).
 *
 * A stable pointer can be "split" into two stable pointers, by
 * dividing the weight by 2 and giving each pointer half.
 * When freeing a stable pointer, the weight of the pointer is added
 * to the weight stored in the table entry.
 * */

139
static HashTable *addrToStableHash = NULL;
140

sof's avatar
sof committed
141
STATIC_INLINE void
142
initSnEntryFreeList(snEntry *table, nat n, snEntry *free)
143 144 145
{
  snEntry *p;
  for (p = table + n - 1; p >= table; p--) {
sof's avatar
sof committed
146
    p->addr   = (P_)free;
147
    p->old    = NULL;
sof's avatar
sof committed
148
    p->sn_obj = NULL;
149 150
    free = p;
  }
151 152 153 154 155 156 157 158 159 160 161
  stable_name_free = table;
}

STATIC_INLINE void
initSpEntryFreeList(spEntry *table, nat n, spEntry *free)
{
  spEntry *p;
  for (p = table + n - 1; p >= table; p--) {
      p->addr = (P_)free;
      free = p;
  }
162 163 164 165
  stable_ptr_free = table;
}

void
166
initStableTables(void)
167
{
168 169 170 171
    if (SNT_size > 0) return;
    SNT_size = INIT_SNT_SIZE;
    stable_name_table = stgMallocBytes(SNT_size * sizeof *stable_name_table,
                                       "initStableNameTable");
172 173 174 175
    /* we don't use index 0 in the stable name table, because that
     * would conflict with the hash table lookup operations which
     * return NULL if an entry isn't found in the hash table.
     */
176
    initSnEntryFreeList(stable_name_table + 1,INIT_SNT_SIZE-1,NULL);
177 178
    addrToStableHash = allocHashTable();

179 180 181 182 183 184
    if (SPT_size > 0) return;
    SPT_size = INIT_SPT_SIZE;
    stable_ptr_table = stgMallocBytes(SPT_size * sizeof *stable_ptr_table,
                                      "initStablePtrTable");
    initSpEntryFreeList(stable_ptr_table,INIT_SPT_SIZE,NULL);

185
#ifdef THREADED_RTS
186
    initMutex(&stable_mutex);
187
#endif
188 189
}

190
void
191
exitStableTables(void)
192
{
193 194 195 196 197 198 199 200 201 202 203 204 205 206
    if (addrToStableHash)
        freeHashTable(addrToStableHash, NULL);
    addrToStableHash = NULL;

    if (stable_name_table)
        stgFree(stable_name_table);
    stable_name_table = NULL;
    SNT_size = 0;

    if (stable_ptr_table)
        stgFree(stable_ptr_table);
    stable_ptr_table = NULL;
    SPT_size = 0;

207
#ifdef THREADED_RTS
208
    closeMutex(&stable_mutex);
209
#endif
210 211
}

sof's avatar
sof committed
212 213
/*
 * get at the real stuff...remove indirections.
Simon Marlow's avatar
Simon Marlow committed
214 215 216
 * It untags pointers before dereferencing and
 * retags the real stuff with its tag (if there
 * is any) when returning.
sof's avatar
sof committed
217 218 219 220 221 222 223
 *
 * ToDo: move to a better home.
 */
static
StgClosure*
removeIndirections(StgClosure* p)
{
Simon Marlow's avatar
Simon Marlow committed
224 225
  StgWord tag = GET_CLOSURE_TAG(p);
  StgClosure* q = UNTAG_CLOSURE(p);
sof's avatar
sof committed
226

227 228
  while (get_itbl(q)->type == IND ||
         get_itbl(q)->type == IND_STATIC ||
229
         get_itbl(q)->type == IND_PERM) {
230
      q = ((StgInd *)q)->indirectee;
Simon Marlow's avatar
Simon Marlow committed
231
      tag = GET_CLOSURE_TAG(q);
232
      q = UNTAG_CLOSURE(q);
sof's avatar
sof committed
233
  }
234

Simon Marlow's avatar
Simon Marlow committed
235
  return TAG_CLOSURE(tag,q);
sof's avatar
sof committed
236 237
}

238 239
static StgWord
lookupStableName_(StgPtr p)
240 241
{
  StgWord sn;
242
  void* sn_tmp;
243

244 245
  if (stable_name_free == NULL) {
    enlargeStableNameTable();
246
  }
sof's avatar
sof committed
247 248

  /* removing indirections increases the likelihood
249
   * of finding a match in the stable name hash table.
sof's avatar
sof committed
250 251 252
   */
  p = (StgPtr)removeIndirections((StgClosure*)p);

Simon Marlow's avatar
Simon Marlow committed
253 254 255
  // register the untagged pointer.  This just makes things simpler.
  p = (StgPtr)UNTAG_CLOSURE((StgClosure*)p);

256 257
  sn_tmp = lookupHashTable(addrToStableHash,(W_)p);
  sn = (StgWord)sn_tmp;
258

259
  if (sn != 0) {
260
    ASSERT(stable_name_table[sn].addr == p);
Simon Marlow's avatar
Simon Marlow committed
261
    debugTrace(DEBUG_stable, "cached stable name %ld at %p",sn,p);
262 263
    return sn;
  }
264 265 266 267 268 269 270 271 272 273 274

  sn = stable_name_free - stable_name_table;
  stable_name_free  = (snEntry*)(stable_name_free->addr);
  stable_name_table[sn].addr = p;
  stable_name_table[sn].sn_obj = NULL;
  /* debugTrace(DEBUG_stable, "new stable name %d at %p\n",sn,p); */

  /* add the new stable name to the hash table */
  insertHashTable(addrToStableHash, (W_)p, (void *)sn);

  return sn;
275 276
}

277 278 279 280
StgWord
lookupStableName(StgPtr p)
{
    StgWord res;
281

282
    initStableTables();
283 284 285 286 287 288
    ACQUIRE_LOCK(&stable_mutex);
    res = lookupStableName_(p);
    RELEASE_LOCK(&stable_mutex);
    return res;
}

sof's avatar
sof committed
289
STATIC_INLINE void
290
freeSnEntry(snEntry *sn)
291
{
292
  ASSERT(sn->sn_obj == NULL);
293 294 295 296
  if(sn->addr != NULL) {
      /* StableName object may die before pointee, in which case we
       * need to remove from hash table, or after pointee, in which
       * case addr==NULL and we already removed it. */
297
      removeHashTable(addrToStableHash, (W_)sn->addr, NULL);
298
  }
299 300 301 302 303 304 305 306 307
  sn->addr = (P_)stable_name_free;
  stable_name_free = sn;
}

STATIC_INLINE void
freeSpEntry(spEntry *sp)
{
    sp->addr = (P_)stable_ptr_free;
    stable_ptr_free = sp;
308 309 310 311 312
}

StgStablePtr
getStablePtr(StgPtr p)
{
313
  StgWord sp;
314

315
  initStableTables();
316
  ACQUIRE_LOCK(&stable_mutex);
317 318 319 320
  if (!stable_ptr_free) enlargeStablePtrTable();
  sp = stable_ptr_free - stable_ptr_table;
  stable_ptr_free  = (spEntry*)(stable_ptr_free->addr);
  stable_ptr_table[sp].addr = p;
321
  RELEASE_LOCK(&stable_mutex);
322
  return (StgStablePtr)(sp);
323 324
}

325
void
326
freeStablePtrUnsafe(StgStablePtr sp)
327
{
328 329 330
    ASSERT((StgWord)sp < SPT_size);
    freeSpEntry(&stable_ptr_table[(StgWord)sp]);
}
331

332 333 334 335
void
freeStablePtr(StgStablePtr sp)
{
    initStableTables();
336
    ACQUIRE_LOCK(&stable_mutex);
337 338 339
    freeStablePtrUnsafe(sp);
    RELEASE_LOCK(&stable_mutex);
}
340

341 342 343 344
static void
enlargeStableNameTable(void)
{
    nat old_SNT_size = SNT_size;
345

346 347 348 349 350 351
    // 2nd and subsequent times
    SNT_size *= 2;
    stable_name_table =
        stgReallocBytes(stable_name_table,
                        SNT_size * sizeof *stable_name_table,
                        "enlargeStableNameTable");
352

353
    initSnEntryFreeList(stable_name_table + old_SNT_size, old_SNT_size, NULL);
354 355
}

Simon Marlow's avatar
Simon Marlow committed
356
static void
357 358
enlargeStablePtrTable(void)
{
359
    nat old_SPT_size = SPT_size;
360

361
    // 2nd and subsequent times
362 363 364 365 366
    SPT_size *= 2;
    stable_ptr_table =
        stgReallocBytes(stable_ptr_table,
                        SPT_size * sizeof *stable_ptr_table,
                        "enlargeStablePtrTable");
sof's avatar
sof committed
367

368
    initSpEntryFreeList(stable_ptr_table + old_SPT_size, old_SPT_size, NULL);
369 370
}

371 372 373 374 375 376
/* -----------------------------------------------------------------------------
 * We must lock the StablePtr table during GC, to prevent simultaneous
 * calls to freeStablePtr().
 * -------------------------------------------------------------------------- */

void
377
stableLock(void)
378
{
379
    initStableTables();
380 381 382 383
    ACQUIRE_LOCK(&stable_mutex);
}

void
384
stableUnlock(void)
385 386 387 388
{
    RELEASE_LOCK(&stable_mutex);
}

389 390 391 392
/* -----------------------------------------------------------------------------
 * Treat stable pointers as roots for the garbage collector.
 * -------------------------------------------------------------------------- */

393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429
#define FOR_EACH_STABLE_PTR(p, CODE)                                    \
    do {                                                                \
        spEntry *p;                                                     \
        spEntry *__end_ptr = &stable_ptr_table[SPT_size];               \
        for (p = stable_ptr_table; p < __end_ptr; p++) {                \
            /* Internal pointers are free slots. NULL is last in free */ \
            /* list. */                                                 \
            if (p->addr &&                                              \
                (p->addr < (P_)stable_ptr_table || p->addr >= (P_)__end_ptr)) \
            {                                                           \
                do { CODE } while(0);                                   \
            }                                                           \
        }                                                               \
    } while(0)

#define FOR_EACH_STABLE_NAME(p, CODE)                                   \
    do {                                                                \
        snEntry *p;                                                     \
        snEntry *__end_ptr = &stable_name_table[SNT_size];              \
        for (p = stable_name_table + 1; p < __end_ptr; p++) {           \
            /* Internal pointers are free slots.  */                    \
            /* If p->addr == NULL, it's a */                            \
            /* stable name where the object has been GC'd, but the */   \
            /* StableName object (sn_obj) is still alive. */            \
            if ((p->addr < (P_)stable_name_table ||                     \
                 p->addr >= (P_)__end_ptr))                             \
            {                                                           \
                /* NOTE: There is an ambiguity here if p->addr == NULL */ \
                /* it is either the last item in the free list or it */ \
                /* is a stable name whose pointee died. sn_obj == NULL */ \
                /* disambiguates as last free list item. */             \
                do { CODE } while(0);                                   \
            }                                                           \
        }                                                               \
    } while(0)

STATIC_INLINE void
430
markStablePtrTable(evac_fn evac, void *user)
431
{
432 433 434 435 436 437 438 439 440 441 442 443 444 445 446
    FOR_EACH_STABLE_PTR(p, evac(user, (StgClosure **)&p->addr););
}

STATIC_INLINE void
rememberOldStableNameAddresses(void)
{
    /* TODO: Only if !full GC */
    FOR_EACH_STABLE_NAME(p, p->old = p->addr;);
}

void
markStableTables(evac_fn evac, void *user)
{
    markStablePtrTable(evac, user);
    rememberOldStableNameAddresses();
447
}
448

449 450
/* -----------------------------------------------------------------------------
 * Thread the stable pointer table for compacting GC.
451
 *
452
 * Here we must call the supplied evac function for each pointer into
453
 * the heap from the stable tables, because the compacting
454 455
 * collector may move the object it points to.
 * -------------------------------------------------------------------------- */
456

457 458 459 460 461 462 463 464 465 466 467 468 469 470
STATIC_INLINE void
threadStableNameTable( evac_fn evac, void *user )
{
    FOR_EACH_STABLE_NAME(p, {
        if (p->sn_obj != NULL) {
            evac(user, (StgClosure **)&p->sn_obj);
        }
        if (p->addr != NULL) {
            evac(user, (StgClosure **)&p->addr);
        }
    });
}

STATIC_INLINE void
471
threadStablePtrTable( evac_fn evac, void *user )
472
{
473 474 475 476 477 478 479 480
    FOR_EACH_STABLE_PTR(p, evac(user, (StgClosure **)&p->addr););
}

void
threadStableTables( evac_fn evac, void *user )
{
    threadStableNameTable(evac, user);
    threadStablePtrTable(evac, user);
481 482 483 484 485 486 487
}

/* -----------------------------------------------------------------------------
 * Garbage collect any dead entries in the stable pointer table.
 *
 * A dead entry has:
 *
488
 *          - a zero reference count
489
 *          - a dead sn_obj
490
 *
491 492 493 494
 * Both of these conditions must be true in order to re-use the stable
 * name table entry.  We can re-use stable name table entries for live
 * heap objects, as long as the program has no StableName objects that
 * refer to the entry.
495 496 497
 * -------------------------------------------------------------------------- */

void
498
gcStableTables( void )
499
{
500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528
    FOR_EACH_STABLE_NAME(
        p, {
            // Update the pointer to the StableName object, if there is one
            if (p->sn_obj != NULL) {
                p->sn_obj = isAlive(p->sn_obj);
                if(p->sn_obj == NULL) {
                    // StableName object died
                    debugTrace(DEBUG_stable, "GC'd StableName %ld (addr=%p)",
                               (long)(p - stable_name_table), p->addr);
                    freeSnEntry(p);
                    /* Can't "continue", so use goto */
                    goto next_stable_name;
                }
            }
            /* If sn_obj became NULL, the object died, and addr is now
             * invalid. But if sn_obj was null, then the StableName
             * object may not have been created yet, while the pointee
             * already exists and must be updated to new location. */
            if (p->addr != NULL) {
                p->addr = (StgPtr)isAlive((StgClosure *)p->addr);
                if(p->addr == NULL) {
                    // StableName pointee died
                    debugTrace(DEBUG_stable, "GC'd pointee %ld",
                               (long)(p - stable_name_table));
                }
            }
    next_stable_name:
            if (0) {}
        });
529 530 531
}

/* -----------------------------------------------------------------------------
532
 * Update the StableName hash table
533 534 535 536 537 538 539 540
 *
 * The boolean argument 'full' indicates that a major collection is
 * being done, so we might as well throw away the hash table and build
 * a new one.  For a minor collection, we just re-hash the elements
 * that changed.
 * -------------------------------------------------------------------------- */

void
541
updateStableTables(rtsBool full)
542
{
543 544 545
    if (full && addrToStableHash != NULL && 0 != keyCountHashTable(addrToStableHash)) {
        freeHashTable(addrToStableHash,NULL);
        addrToStableHash = allocHashTable();
546
    }
547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566

    if(full) {
        FOR_EACH_STABLE_NAME(
            p, {
                if (p->addr != NULL) {
                    // Target still alive, Re-hash this stable name
                    insertHashTable(addrToStableHash, (W_)p->addr, (void *)(p - stable_name_table));
                }
            });
    } else {
        FOR_EACH_STABLE_NAME(
            p, {
                if (p->addr != p->old) {
                    removeHashTable(addrToStableHash, (W_)p->old, NULL);
                    /* Movement happened: */
                    if (p->addr != NULL) {
                        insertHashTable(addrToStableHash, (W_)p->addr, (void *)(p - stable_name_table));
                    }
                }
            });
567 568
    }
}