ghc/rts/Stable.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Stable.c,v 1.1 1999/01/27 10:11:27 simonm Exp $
   3  *
   4  * (c) The GHC Team 1998-1999
   5  *
   6  * Stable names and stable pointers.
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #include "Rts.h"
  11 #include "Hash.h"
  12 #include "StablePriv.h"
  13 #include "GC.h"
  14 #include "RtsUtils.h"
  15 #include "Storage.h"
  16 #include "RtsAPI.h"
  17 #include "RtsFlags.h"
  18
  19 /* Comment from ADR's implementation in old RTS:
  20
  21   This files (together with @ghc/runtime/storage/PerformIO.lhc@ and a
  22   small change in @HpOverflow.lc@) consists of the changes in the
  23   runtime system required to implement "Stable Pointers". But we're
  24   getting a bit ahead of ourselves --- what is a stable pointer and what
  25   is it used for?
  26
  27   When Haskell calls C, it normally just passes over primitive integers,
  28   floats, bools, strings, etc.  This doesn't cause any problems at all
  29   for garbage collection because the act of passing them makes a copy
  30   from the heap, stack or wherever they are onto the C-world stack.
  31   However, if we were to pass a heap object such as a (Haskell) @String@
  32   and a garbage collection occured before we finished using it, we'd run
  33   into problems since the heap object might have been moved or even
  34   deleted.
  35
  36   So, if a C call is able to cause a garbage collection or we want to
  37   store a pointer to a heap object between C calls, we must be careful
  38   when passing heap objects. Our solution is to keep a table of all
  39   objects we've given to the C-world and to make sure that the garbage
  40   collector collects these objects --- updating the table as required to
  41   make sure we can still find the object.
  42
  43
  44   Of course, all this rather begs the question: why would we want to
  45   pass a boxed value?
  46
  47   One very good reason is to preserve laziness across the language
  48   interface. Rather than evaluating an integer or a string because it
  49   {\em might\/} be required by the C function, we can wait until the C
  50   function actually wants the value and then force an evaluation.
  51
  52   Another very good reason (the motivating reason!) is that the C code
  53   might want to execute an object of sort $IO ()$ for the side-effects
  54   it will produce. For example, this is used when interfacing to an X
  55   widgets library to allow a direct implementation of callbacks.
  56
  57
  58   The @makeStablePointer :: a -> IO (StablePtr a)@ function
  59   converts a value into a stable pointer.  It is part of the @PrimIO@
  60   monad, because we want to be sure we don't allocate one twice by
  61   accident, and then only free one of the copies.
  62
  63   \begin{verbatim}
  64   makeStablePtr#  :: a -> State# RealWorld -> (# RealWorld, a #)
  65   freeStablePtr#  :: StablePtr# a -> State# RealWorld -> State# RealWorld
  66   deRefStablePtr# :: StablePtr# a -> State# RealWorld ->
  67         (# State# RealWorld, a #)
  68   \end{verbatim}
  69   There is also a C procedure @FreeStablePtr@ which frees a stable pointer.
  70
  71   There may be additional functions on the C side to allow evaluation,
  72   application, etc of a stable pointer.
  73
  74   When Haskell calls C, it normally just passes over primitive integers,
  75   floats, bools, strings, etc.  This doesn't cause any problems at all
  76   for garbage collection because the act of passing them makes a copy
  77   from the heap, stack or wherever they are onto the C-world stack.
  78   However, if we were to pass a heap object such as a (Haskell) @String@
  79   and a garbage collection occured before we finished using it, we'd run
  80   into problems since the heap object might have been moved or even
  81   deleted.
  82
  83   So, if a C call is able to cause a garbage collection or we want to
  84   store a pointer to a heap object between C calls, we must be careful
  85   when passing heap objects. Our solution is to keep a table of all
  86   objects we've given to the C-world and to make sure that the garbage
  87   collector collects these objects --- updating the table as required to
  88   make sure we can still find the object.
  89 */
  90
  91 snEntry *stable_ptr_table;
  92 snEntry *stable_ptr_free;
  93
  94 unsigned int SPT_size;
  95
  96 /* This hash table maps Haskell objects to stable names, so that every
  97  * call to lookupStableName on a given object will return the same
  98  * stable name.
  99  *
 100  * Reference counting
 101  * ------------------
 102  * A plain stable name entry has a zero reference count, which means
 103  * the entry will dissappear when the object it points to is
 104  * unreachable.  For stable pointers, we need an entry that sticks
 105  * around and keeps the object it points to alive, so each stable name
 106  * entry has an associated reference count.
 107  *
 108  * A stable pointer has a weighted reference count N attached to it
 109  * (actually in its upper 5 bits), which represents the weight
 110  * 2^N.  The stable name entry keeps a 32-bit reference count, which
 111  * represents any weight between 1 and 2^32 (represented as zero).
 112  * When the weight is 2^32, the stable name table owns "all" of the
 113  * stable pointers to this object, and the entry can be garbage
 114  * collected if the object isn't reachable.
 115  *
 116  * A new stable pointer is given the weight log2(W/2), where W is the
 117  * weight stored in the table entry.  The new weight in the table is W
 118  * - 2^log2(W/2).
 119  *
 120  * A stable pointer can be "split" into two stable pointers, by
 121  * dividing the weight by 2 and giving each pointer half.
 122  * When freeing a stable pointer, the weight of the pointer is added
 123  * to the weight stored in the table entry.
 124  * */
 125
 126 HashTable *addrToStableHash;
 127
 128 #define INIT_SPT_SIZE 64
 129
 130 static inline void
 131 initFreeList(snEntry *table, nat n, snEntry *free)
 132 {
 133   snEntry *p;
 134
 135   for (p = table + n - 1; p >= table; p--) {
 136     p->addr = (P_)free;
 137     free = p;
 138   }
 139   stable_ptr_free = table;
 140 }
 141
 142 void
 143 initStablePtrTable(void)
 144 {
 145   /* the table will be allocated the first time makeStablePtr is
 146    * called */
 147   stable_ptr_table = NULL;
 148   stable_ptr_free  = NULL;
 149   addrToStableHash = NULL;
 150   SPT_size = 0;
 151 }
 152
 153 StgWord
 154 lookupStableName(StgPtr p)
 155 {
 156   StgWord sn;
 157
 158   if (stable_ptr_free == NULL) {
 159     enlargeStablePtrTable();
 160   }
 161
 162   (void *)sn = lookupHashTable(addrToStableHash,(W_)p);
 163
 164   if (sn != 0) {
 165     ASSERT(stable_ptr_table[sn].addr == p);
 166     IF_DEBUG(stable,fprintf(stderr,"cached stable name %d at %p\n",sn,p));
 167     return sn;
 168   } else {
 169     sn = stable_ptr_free - stable_ptr_table;
 170     (P_)stable_ptr_free  = stable_ptr_free->addr;
 171     stable_ptr_table[sn].weight = 0;
 172     stable_ptr_table[sn].addr = p;
 173     /* IF_DEBUG(stable,fprintf(stderr,"new stable name %d at
 174        %p\n",sn,p)); */
 175
 176     /* add the new stable name to the hash table */
 177     insertHashTable(addrToStableHash, (W_)p, (void *)sn);
 178
 179     return sn;
 180   }
 181 }
 182
 183 static inline void
 184 freeStableName(snEntry *sn)
 185 {
 186   sn->addr = (P_)stable_ptr_free;
 187   stable_ptr_free = sn;
 188 }
 189
 190 StgStablePtr
 191 getStablePtr(StgPtr p)
 192 {
 193   StgWord sn = lookupStableName(p);
 194   StgWord weight, weight_2;
 195
 196   weight = stable_ptr_table[sn].weight;
 197   if (weight == 0) {
 198     weight = 1 << (BITS_IN(StgWord)-1);
 199     stable_ptr_table[sn].weight = weight;
 200     return (StgStablePtr)(sn + ((BITS_IN(StgWord)-1) << STABLEPTR_WEIGHT_SHIFT));
 201   }
 202   else if (weight == 1) {
 203     barf("getStablePtr: too light");
 204   }
 205   else {
 206     weight /= 2;
 207     /* find log2(weight) */
 208     for (weight_2 = 1; weight != 1; weight_2++) {
 209       weight >>= 1;
 210     }
 211     stable_ptr_table[sn].weight -= 2^weight_2;
 212     return (StgStablePtr)(sn + (weight_2 << STABLEPTR_WEIGHT_SHIFT));
 213   }
 214 }
 215
 216 void
 217 enlargeStablePtrTable(void)
 218 {
 219   nat old_SPT_size = SPT_size;
 220
 221   if (SPT_size == 0) {
 222     /* 1st time */
 223     SPT_size = INIT_SPT_SIZE;
 224     stable_ptr_table = stgMallocWords(SPT_size * sizeof(snEntry),
 225                                       "initStablePtrTable");
 226
 227     initFreeList(stable_ptr_table+1,INIT_SPT_SIZE-1,NULL);
 228     addrToStableHash = allocHashTable();
 229   }
 230   else {
 231     /* 2nd and subsequent times */
 232     SPT_size *= 2;
 233     stable_ptr_table =
 234       stgReallocWords(stable_ptr_table, SPT_size * sizeof(snEntry),
 235                       "enlargeStablePtrTable");
 236
 237     initFreeList(stable_ptr_table + old_SPT_size, old_SPT_size, NULL);
 238   }
 239 }
 240
 241 /* -----------------------------------------------------------------------------
 242  * Treat stable pointers as roots for the garbage collector.
 243  *
 244  * A stable pointer is any stable name entry with a weight > 0.  We'll
 245  * take the opportunity to zero the "keep" flags at the same time.
 246  * -------------------------------------------------------------------------- */
 247
 248 void
 249 markStablePtrTable(rtsBool full)
 250 {
 251   snEntry *p, *end_stable_ptr_table;
 252   StgPtr q;
 253   StgClosure *new;
 254
 255   if (SPT_size == 0)
 256     return;
 257
 258   if (full) {
 259     freeHashTable(addrToStableHash,NULL);
 260     addrToStableHash = allocHashTable();
 261   }
 262
 263   end_stable_ptr_table = &stable_ptr_table[SPT_size];
 264
 265   /* Mark all the stable *pointers* (not stable names)
 266    */
 267   for (p = stable_ptr_table; p < end_stable_ptr_table; p++) {
 268     q = p->addr;
 269     /* internal pointers or NULL are free slots */
 270     if (q && (q < (P_)stable_ptr_table || q >= (P_)end_stable_ptr_table)) {
 271       if (p->weight != 0) {
 272         new = MarkRoot((StgClosure *)q);
 273         /* Update the hash table */
 274         if (full) {
 275           insertHashTable(addrToStableHash, (W_)new, (void *)(p - stable_ptr_table));
 276           (StgClosure *)p->addr = new;
 277         } else if ((P_)new != q) {
 278           removeHashTable(addrToStableHash, (W_)q, NULL);
 279           insertHashTable(addrToStableHash, (W_)new, (void *)(p - stable_ptr_table));
 280           (StgClosure *)p->addr = new;
 281         }
 282         /* IF_DEBUG(stable, fprintf(stderr,"Stable ptr %d still alive
 283            at %p, weight %d\n", p - stable_ptr_table, new,
 284            p->weight)); */
 285       }
 286       else {
 287         /* reset the keep flag */
 288         p->keep = rtsFalse;
 289       }
 290     }
 291   }
 292 }
 293
 294 /* -----------------------------------------------------------------------------
 295  * Garbage collect any dead entries in the stable pointer table.
 296  *
 297  * A dead entry has:
 298  *
 299  *          - a weight of zero (i.e. 2^32)
 300  *          - a false keep flag
 301  *
 302  * The keep flag is set by the garbage collector whenever it
 303  * encounters a StableName object on the heap.
 304  *
 305  * The boolean argument 'full' indicates that a major collection is
 306  * being done, so we might as well throw away the hash table and build
 307  * a new one.  For a minor collection, we just re-hash the elements
 308  * that changed.
 309  * -------------------------------------------------------------------------- */
 310
 311 void
 312 gcStablePtrTable(rtsBool full)
 313 {
 314   snEntry *p, *end_stable_ptr_table;
 315   StgPtr q, new;
 316
 317   if (SPT_size == 0) {
 318     return;
 319   }
 320
 321   end_stable_ptr_table = &stable_ptr_table[SPT_size];
 322
 323   for (p = stable_ptr_table; p < end_stable_ptr_table; p++) {
 324     q = p->addr;
 325
 326     if (q && (q < (P_)stable_ptr_table || q >= (P_)end_stable_ptr_table)) {
 327
 328       /* We're only interested in Stable Names here. */
 329       if (p->weight == 0) {
 330
 331         if (((StgClosure *)new = isAlive((StgClosure *)q))) {
 332           IF_DEBUG(stable, fprintf(stderr,"Stable name %d still alive at %p, weight %d\n", p - stable_ptr_table, new, p->weight));
 333
 334           p->addr = new;
 335           /* Re-hash this stable name */
 336           if (full) {
 337             insertHashTable(addrToStableHash, (W_)new, (void *)(p - stable_ptr_table));
 338           } else if (new != q) {
 339             removeHashTable(addrToStableHash, (W_)q, NULL);
 340             insertHashTable(addrToStableHash, (W_)new, (void *)(p - stable_ptr_table));
 341           }
 342         }
 343
 344         else {
 345           /* If there are still StableName objects in the heap
 346            * pointing to this entry (p->keep == rtsTrue), then
 347            * don't free the entry just yet.
 348            */
 349           if (p->keep)
 350             p->addr = NULL;
 351           else
 352             freeStableName(p);
 353         }
 354       }
 355     }
 356   }
 357 }