Stable.c 17.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
  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
86
  http://ghc.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
/*
 * This hash table maps Haskell objects to stable names, so that every
108 109
 * call to lookupStableName on a given object will return the same
 * stable name.
110
 */
111

112
static HashTable *addrToStableHash = NULL;
113

114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135
/* -----------------------------------------------------------------------------
 * We must lock the StablePtr table during GC, to prevent simultaneous
 * calls to freeStablePtr().
 * -------------------------------------------------------------------------- */

void
stableLock(void)
{
    initStableTables();
    ACQUIRE_LOCK(&stable_mutex);
}

void
stableUnlock(void)
{
    RELEASE_LOCK(&stable_mutex);
}

/* -----------------------------------------------------------------------------
 * Initialising the tables
 * -------------------------------------------------------------------------- */

sof's avatar
sof committed
136
STATIC_INLINE void
137
initSnEntryFreeList(snEntry *table, nat n, snEntry *free)
138 139 140
{
  snEntry *p;
  for (p = table + n - 1; p >= table; p--) {
sof's avatar
sof committed
141
    p->addr   = (P_)free;
142
    p->old    = NULL;
sof's avatar
sof committed
143
    p->sn_obj = NULL;
144 145
    free = p;
  }
146 147 148 149 150 151 152 153 154 155 156
  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;
  }
157 158 159 160
  stable_ptr_free = table;
}

void
161
initStableTables(void)
162
{
163 164 165 166
    if (SNT_size > 0) return;
    SNT_size = INIT_SNT_SIZE;
    stable_name_table = stgMallocBytes(SNT_size * sizeof *stable_name_table,
                                       "initStableNameTable");
167 168 169 170
    /* 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.
     */
171
    initSnEntryFreeList(stable_name_table + 1,INIT_SNT_SIZE-1,NULL);
172 173
    addrToStableHash = allocHashTable();

174 175 176 177 178 179
    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);

180
#ifdef THREADED_RTS
181
    initMutex(&stable_mutex);
182
#endif
183 184
}

185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222
/* -----------------------------------------------------------------------------
 * Enlarging the tables
 * -------------------------------------------------------------------------- */

static void
enlargeStableNameTable(void)
{
    nat old_SNT_size = SNT_size;

    // 2nd and subsequent times
    SNT_size *= 2;
    stable_name_table =
        stgReallocBytes(stable_name_table,
                        SNT_size * sizeof *stable_name_table,
                        "enlargeStableNameTable");

    initSnEntryFreeList(stable_name_table + old_SNT_size, old_SNT_size, NULL);
}

static void
enlargeStablePtrTable(void)
{
    nat old_SPT_size = SPT_size;

    // 2nd and subsequent times
    SPT_size *= 2;
    stable_ptr_table =
        stgReallocBytes(stable_ptr_table,
                        SPT_size * sizeof *stable_ptr_table,
                        "enlargeStablePtrTable");

    initSpEntryFreeList(stable_ptr_table + old_SPT_size, old_SPT_size, NULL);
}

/* -----------------------------------------------------------------------------
 * Freeing entries and tables
 * -------------------------------------------------------------------------- */

223
void
224
exitStableTables(void)
225
{
226 227 228 229 230 231 232 233 234 235 236 237 238 239
    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;

240
#ifdef THREADED_RTS
241
    closeMutex(&stable_mutex);
242
#endif
243 244
}

245 246 247 248
STATIC_INLINE void
freeSnEntry(snEntry *sn)
{
  ASSERT(sn->sn_obj == NULL);
249
  removeHashTable(addrToStableHash, (W_)sn->old, NULL);
250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279
  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;
}

void
freeStablePtrUnsafe(StgStablePtr sp)
{
    ASSERT((StgWord)sp < SPT_size);
    freeSpEntry(&stable_ptr_table[(StgWord)sp]);
}

void
freeStablePtr(StgStablePtr sp)
{
    stableLock();
    freeStablePtrUnsafe(sp);
    stableUnlock();
}

/* -----------------------------------------------------------------------------
 * Looking up
 * -------------------------------------------------------------------------- */

sof's avatar
sof committed
280 281 282
/*
 * get at the real stuff...remove indirections.
 */
283 284
static StgClosure*
removeIndirections (StgClosure* p)
sof's avatar
sof committed
285
{
286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310
    StgClosure* q;

    while (1)
    {
        q = UNTAG_CLOSURE(p);

        switch (get_itbl(q)->type) {
        case IND:
        case IND_STATIC:
            p = ((StgInd *)q)->indirectee;
            continue;

        case BLACKHOLE:
            p = ((StgInd *)q)->indirectee;
            if (GET_CLOSURE_TAG(p) != 0) {
                continue;
            } else {
                break;
            }

        default:
            break;
        }
        return p;
    }
sof's avatar
sof committed
311 312
}

313 314
StgWord
lookupStableName (StgPtr p)
315 316
{
  StgWord sn;
317
  void* sn_tmp;
318

319 320
  stableLock();

321 322
  if (stable_name_free == NULL) {
    enlargeStableNameTable();
323
  }
sof's avatar
sof committed
324 325

  /* removing indirections increases the likelihood
326
   * of finding a match in the stable name hash table.
sof's avatar
sof committed
327 328 329
   */
  p = (StgPtr)removeIndirections((StgClosure*)p);

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

333 334
  sn_tmp = lookupHashTable(addrToStableHash,(W_)p);
  sn = (StgWord)sn_tmp;
335

336
  if (sn != 0) {
337
    ASSERT(stable_name_table[sn].addr == p);
Simon Marlow's avatar
Simon Marlow committed
338
    debugTrace(DEBUG_stable, "cached stable name %ld at %p",sn,p);
339
    stableUnlock();
340 341
    return sn;
  }
342 343 344 345 346 347 348 349 350 351

  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);

352
  stableUnlock();
353

354
  return sn;
355 356 357 358 359
}

StgStablePtr
getStablePtr(StgPtr p)
{
360
  StgWord sp;
361

362
  stableLock();
363 364 365 366
  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;
367
  stableUnlock();
368
  return (StgStablePtr)(sp);
369 370 371 372 373 374
}

/* -----------------------------------------------------------------------------
 * Treat stable pointers as roots for the garbage collector.
 * -------------------------------------------------------------------------- */

375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411
#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
412
markStablePtrTable(evac_fn evac, void *user)
413
{
414 415 416 417 418 419 420 421 422 423 424 425 426 427 428
    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();
429
}
430

431 432
/* -----------------------------------------------------------------------------
 * Thread the stable pointer table for compacting GC.
433
 *
434
 * Here we must call the supplied evac function for each pointer into
435
 * the heap from the stable tables, because the compacting
436 437
 * collector may move the object it points to.
 * -------------------------------------------------------------------------- */
438

439 440 441 442 443 444 445 446 447 448 449 450 451 452
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
453
threadStablePtrTable( evac_fn evac, void *user )
454
{
455 456 457 458 459 460 461 462
    FOR_EACH_STABLE_PTR(p, evac(user, (StgClosure **)&p->addr););
}

void
threadStableTables( evac_fn evac, void *user )
{
    threadStableNameTable(evac, user);
    threadStablePtrTable(evac, user);
463 464 465 466 467 468 469
}

/* -----------------------------------------------------------------------------
 * Garbage collect any dead entries in the stable pointer table.
 *
 * A dead entry has:
 *
470
 *          - a zero reference count
471
 *          - a dead sn_obj
472
 *
473 474 475 476
 * 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.
477 478 479
 * -------------------------------------------------------------------------- */

void
480
gcStableTables( void )
481
{
482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510
    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) {}
        });
511 512 513
}

/* -----------------------------------------------------------------------------
514
 * Update the StableName hash table
515 516 517 518 519 520 521 522
 *
 * 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
523
updateStableTables(rtsBool full)
524
{
525 526 527
    if (full && addrToStableHash != NULL && 0 != keyCountHashTable(addrToStableHash)) {
        freeHashTable(addrToStableHash,NULL);
        addrToStableHash = allocHashTable();
528
    }
529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548

    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));
                    }
                }
            });
549 550
    }
}