Stable.c 17.2 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
/*
 * 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 249 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
STATIC_INLINE void
freeSnEntry(snEntry *sn)
{
  ASSERT(sn->sn_obj == NULL);
  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
279 280
/*
 * get at the real stuff...remove indirections.
Simon Marlow's avatar
Simon Marlow committed
281 282 283
 * It untags pointers before dereferencing and
 * retags the real stuff with its tag (if there
 * is any) when returning.
sof's avatar
sof committed
284 285 286 287 288 289 290
 *
 * ToDo: move to a better home.
 */
static
StgClosure*
removeIndirections(StgClosure* p)
{
Simon Marlow's avatar
Simon Marlow committed
291 292
  StgWord tag = GET_CLOSURE_TAG(p);
  StgClosure* q = UNTAG_CLOSURE(p);
sof's avatar
sof committed
293

294 295
  while (get_itbl(q)->type == IND ||
         get_itbl(q)->type == IND_STATIC ||
296
         get_itbl(q)->type == IND_PERM) {
297
      q = ((StgInd *)q)->indirectee;
Simon Marlow's avatar
Simon Marlow committed
298
      tag = GET_CLOSURE_TAG(q);
299
      q = UNTAG_CLOSURE(q);
sof's avatar
sof committed
300
  }
301

Simon Marlow's avatar
Simon Marlow committed
302
  return TAG_CLOSURE(tag,q);
sof's avatar
sof committed
303 304
}

305 306
StgWord
lookupStableName (StgPtr p)
307 308
{
  StgWord sn;
309
  void* sn_tmp;
310

311 312
  stableLock();

313 314
  if (stable_name_free == NULL) {
    enlargeStableNameTable();
315
  }
sof's avatar
sof committed
316 317

  /* removing indirections increases the likelihood
318
   * of finding a match in the stable name hash table.
sof's avatar
sof committed
319 320 321
   */
  p = (StgPtr)removeIndirections((StgClosure*)p);

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

325 326
  sn_tmp = lookupHashTable(addrToStableHash,(W_)p);
  sn = (StgWord)sn_tmp;
327

328
  if (sn != 0) {
329
    ASSERT(stable_name_table[sn].addr == p);
Simon Marlow's avatar
Simon Marlow committed
330
    debugTrace(DEBUG_stable, "cached stable name %ld at %p",sn,p);
331
    stableUnlock();
332 333
    return sn;
  }
334 335 336 337 338 339 340 341 342 343

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

344
  stableUnlock();
345

346
  return sn;
347 348 349 350 351
}

StgStablePtr
getStablePtr(StgPtr p)
{
352
  StgWord sp;
353

354
  stableLock();
355 356 357 358
  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;
359
  stableUnlock();
360
  return (StgStablePtr)(sp);
361 362 363 364 365 366
}

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

367 368 369 370 371 372 373 374 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
#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
404
markStablePtrTable(evac_fn evac, void *user)
405
{
406 407 408 409 410 411 412 413 414 415 416 417 418 419 420
    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();
421
}
422

423 424
/* -----------------------------------------------------------------------------
 * Thread the stable pointer table for compacting GC.
425
 *
426
 * Here we must call the supplied evac function for each pointer into
427
 * the heap from the stable tables, because the compacting
428 429
 * collector may move the object it points to.
 * -------------------------------------------------------------------------- */
430

431 432 433 434 435 436 437 438 439 440 441 442 443 444
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
445
threadStablePtrTable( evac_fn evac, void *user )
446
{
447 448 449 450 451 452 453 454
    FOR_EACH_STABLE_PTR(p, evac(user, (StgClosure **)&p->addr););
}

void
threadStableTables( evac_fn evac, void *user )
{
    threadStableNameTable(evac, user);
    threadStablePtrTable(evac, user);
455 456 457 458 459 460 461
}

/* -----------------------------------------------------------------------------
 * Garbage collect any dead entries in the stable pointer table.
 *
 * A dead entry has:
 *
462
 *          - a zero reference count
463
 *          - a dead sn_obj
464
 *
465 466 467 468
 * 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.
469 470 471
 * -------------------------------------------------------------------------- */

void
472
gcStableTables( void )
473
{
474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502
    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) {}
        });
503 504 505
}

/* -----------------------------------------------------------------------------
506
 * Update the StableName hash table
507 508 509 510 511 512 513 514
 *
 * 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
515
updateStableTables(rtsBool full)
516
{
517 518 519
    if (full && addrToStableHash != NULL && 0 != keyCountHashTable(addrToStableHash)) {
        freeHashTable(addrToStableHash,NULL);
        addrToStableHash = allocHashTable();
520
    }
521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540

    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));
                    }
                }
            });
541 542
    }
}