ghc/rts/Storage.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Storage.c,v 1.16 1999/03/02 19:50:12 sof Exp $
   3  *
   4  * (c) The GHC Team, 1998-1999
   5  *
   6  * Storage manager front end
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #include "Rts.h"
  11 #include "RtsUtils.h"
  12 #include "RtsFlags.h"
  13 #include "Stats.h"
  14 #include "Hooks.h"
  15 #include "BlockAlloc.h"
  16 #include "MBlock.h"
  17 #include "gmp.h"
  18 #include "Weak.h"
  19 #include "Sanity.h"
  20
  21 #include "Storage.h"
  22 #include "StoragePriv.h"
  23
  24 bdescr *current_nursery;        /* next available nursery block, or NULL */
  25 nat nursery_blocks;             /* number of blocks in the nursery */
  26
  27 StgClosure    *caf_list         = NULL;
  28
  29 bdescr *small_alloc_list;       /* allocate()d small objects */
  30 bdescr *large_alloc_list;       /* allocate()d large objects */
  31 nat alloc_blocks;               /* number of allocate()d blocks since GC */
  32 nat alloc_blocks_lim;           /* approximate limit on alloc_blocks */
  33
  34 StgPtr alloc_Hp    = NULL;      /* next free byte in small_alloc_list */
  35 StgPtr alloc_HpLim = NULL;      /* end of block at small_alloc_list   */
  36
  37 generation *generations;        /* all the generations */
  38 generation *g0;                 /* generation 0, for convenience */
  39 generation *oldest_gen;         /* oldest generation, for convenience */
  40 step *g0s0;                     /* generation 0, step 0, for convenience */
  41
  42 /*
  43  * Forward references
  44  */
  45 static void *stgAllocForGMP   (size_t size_in_bytes);
  46 static void *stgReallocForGMP (void *ptr, size_t old_size, size_t new_size);
  47 static void  stgDeallocForGMP (void *ptr, size_t size);
  48
  49 void
  50 initStorage (void)
  51 {
  52   nat g, s;
  53   step *step;
  54   generation *gen;
  55
  56   if (RtsFlags.GcFlags.heapSizeSuggestion >
  57       RtsFlags.GcFlags.maxHeapSize) {
  58     RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion;
  59   }
  60
  61   initBlockAllocator();
  62
  63   /* allocate generation info array */
  64   generations = (generation *)stgMallocBytes(RtsFlags.GcFlags.generations
  65                                              * sizeof(struct _generation),
  66                                              "initStorage: gens");
  67
  68   /* Initialise all generations */
  69   for(g = 0; g < RtsFlags.GcFlags.generations; g++) {
  70     gen = &generations[g];
  71     gen->no = g;
  72     gen->mut_list = END_MUT_LIST;
  73     gen->mut_once_list = END_MUT_LIST;
  74     gen->collections = 0;
  75     gen->failed_promotions = 0;
  76     gen->max_blocks = 0;
  77   }
  78
  79   /* A couple of convenience pointers */
  80   g0 = &generations[0];
  81   oldest_gen = &generations[RtsFlags.GcFlags.generations-1];
  82
  83   /* Allocate step structures in each generation */
  84   if (RtsFlags.GcFlags.generations > 1) {
  85     /* Only for multiple-generations */
  86
  87     /* Oldest generation: one step */
  88     oldest_gen->n_steps = 1;
  89     oldest_gen->steps =
  90       stgMallocBytes(1 * sizeof(struct _step), "initStorage: last step");
  91
  92     /* set up all except the oldest generation with 2 steps */
  93     for(g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
  94       generations[g].n_steps = RtsFlags.GcFlags.steps;
  95       generations[g].steps  =
  96         stgMallocBytes (RtsFlags.GcFlags.steps * sizeof(struct _step),
  97                         "initStorage: steps");
  98     }
  99
 100   } else {
 101     /* single generation, i.e. a two-space collector */
 102     g0->n_steps = 1;
 103     g0->steps = stgMallocBytes (sizeof(struct _step), "initStorage: steps");
 104   }
 105
 106   /* Initialise all steps */
 107   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 108     for (s = 0; s < generations[g].n_steps; s++) {
 109       step = &generations[g].steps[s];
 110       step->no = s;
 111       step->blocks = NULL;
 112       step->n_blocks = 0;
 113       step->gen = &generations[g];
 114       step->hp = NULL;
 115       step->hpLim = NULL;
 116       step->hp_bd = NULL;
 117       step->scan = NULL;
 118       step->scan_bd = NULL;
 119       step->large_objects = NULL;
 120       step->new_large_objects = NULL;
 121       step->scavenged_large_objects = NULL;
 122     }
 123   }
 124
 125   /* Set up the destination pointers in each younger gen. step */
 126   for (g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
 127     for (s = 0; s < generations[g].n_steps-1; s++) {
 128       generations[g].steps[s].to = &generations[g].steps[s+1];
 129     }
 130     generations[g].steps[s].to = &generations[g+1].steps[0];
 131   }
 132
 133   /* The oldest generation has one step and its destination is the
 134    * same step. */
 135   oldest_gen->steps[0].to = &oldest_gen->steps[0];
 136
 137   /* generation 0 is special: that's the nursery */
 138   generations[0].max_blocks = 0;
 139
 140   /* G0S0: the allocation area.  Policy: keep the allocation area
 141    * small to begin with, even if we have a large suggested heap
 142    * size.  Reason: we're going to do a major collection first, and we
 143    * don't want it to be a big one.  This vague idea is borne out by
 144    * rigorous experimental evidence.
 145    */
 146   step = &generations[0].steps[0];
 147   g0s0 = step;
 148   nursery_blocks = RtsFlags.GcFlags.minAllocAreaSize;
 149   step->blocks   = allocNursery(NULL, nursery_blocks);
 150   step->n_blocks = nursery_blocks;
 151   current_nursery = step->blocks;
 152   g0s0->to_space = NULL;
 153   /* hp, hpLim, hp_bd, to_space etc. aren't used in G0S0 */
 154
 155   weak_ptr_list = NULL;
 156   caf_list = NULL;
 157
 158   /* initialise the allocate() interface */
 159   small_alloc_list = NULL;
 160   large_alloc_list = NULL;
 161   alloc_blocks = 0;
 162   alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
 163
 164 #ifdef COMPILER
 165   /* Tell GNU multi-precision pkg about our custom alloc functions */
 166   mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);
 167 #endif
 168
 169   IF_DEBUG(gc, stat_describe_gens());
 170 }
 171
 172 extern bdescr *
 173 allocNursery (bdescr *last_bd, nat blocks)
 174 {
 175   bdescr *bd;
 176   nat i;
 177
 178   /* Allocate a nursery */
 179   for (i=0; i < blocks; i++) {
 180     bd = allocBlock();
 181     bd->link = last_bd;
 182     bd->step = g0s0;
 183     bd->gen = g0;
 184     bd->evacuated = 0;
 185     bd->free = bd->start;
 186     last_bd = bd;
 187   }
 188   return last_bd;
 189 }
 190
 191 extern void
 192 resizeNursery ( nat blocks )
 193 {
 194   bdescr *bd;
 195
 196   if (nursery_blocks == blocks) {
 197     ASSERT(g0s0->n_blocks == blocks);
 198     return;
 199   }
 200
 201   else if (nursery_blocks < blocks) {
 202     IF_DEBUG(gc, fprintf(stderr, "Increasing size of nursery to %d blocks\n",
 203                          blocks));
 204     g0s0->blocks = allocNursery(g0s0->blocks, blocks-nursery_blocks);
 205   }
 206
 207   else {
 208     bdescr *next_bd;
 209
 210     IF_DEBUG(gc, fprintf(stderr, "Decreasing size of nursery to %d blocks\n",
 211                          blocks));
 212     for (bd = g0s0->blocks; nursery_blocks > blocks; nursery_blocks--) {
 213       next_bd = bd->link;
 214       freeGroup(bd);
 215       bd = next_bd;
 216     }
 217     g0s0->blocks = bd;
 218   }
 219
 220   g0s0->n_blocks = nursery_blocks = blocks;
 221 }
 222
 223 void
 224 exitStorage (void)
 225 {
 226   lnat allocated;
 227   bdescr *bd;
 228
 229   /* Return code ignored for now */
 230   /* ToDo: allocation figure is slightly wrong (see also GarbageCollect()) */
 231   allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
 232   for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
 233     allocated -= BLOCK_SIZE_W;
 234   }
 235   stat_exit(allocated);
 236 }
 237
 238 void
 239 newCAF(StgClosure* caf)
 240 {
 241   /* Put this CAF on the mutable list for the old generation.
 242    * This is a HACK - the IND_STATIC closure doesn't really have
 243    * a mut_link field, but we pretend it has - in fact we re-use
 244    * the STATIC_LINK field for the time being, because when we
 245    * come to do a major GC we won't need the mut_link field
 246    * any more and can use it as a STATIC_LINK.
 247    */
 248   ((StgMutClosure *)caf)->mut_link = oldest_gen->mut_once_list;
 249   oldest_gen->mut_once_list = (StgMutClosure *)caf;
 250
 251 #ifdef DEBUG
 252   {
 253     const StgInfoTable *info;
 254
 255     info = get_itbl(caf);
 256     ASSERT(info->type == IND_STATIC);
 257     STATIC_LINK2(info,caf) = caf_list;
 258     caf_list = caf;
 259   }
 260 #endif
 261 }
 262
 263 /* -----------------------------------------------------------------------------
 264    The allocate() interface
 265
 266    allocate(n) always succeeds, and returns a chunk of memory n words
 267    long.  n can be larger than the size of a block if necessary, in
 268    which case a contiguous block group will be allocated.
 269    -------------------------------------------------------------------------- */
 270
 271 StgPtr
 272 allocate(nat n)
 273 {
 274   bdescr *bd;
 275   StgPtr p;
 276
 277   TICK_ALLOC_HEAP(n);
 278   CCS_ALLOC(CCCS,n);
 279
 280   /* big allocation (>LARGE_OBJECT_THRESHOLD) */
 281   /* ToDo: allocate directly into generation 1 */
 282   if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
 283     nat req_blocks =  (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
 284     bd = allocGroup(req_blocks);
 285     dbl_link_onto(bd, &g0s0->large_objects);
 286     bd->gen  = g0;
 287     bd->step = g0s0;
 288     bd->evacuated = 0;
 289     bd->free = bd->start;
 290     /* don't add these blocks to alloc_blocks, since we're assuming
 291      * that large objects are likely to remain live for quite a while
 292      * (eg. running threads), so garbage collecting early won't make
 293      * much difference.
 294      */
 295     return bd->start;
 296
 297   /* small allocation (<LARGE_OBJECT_THRESHOLD) */
 298   } else if (small_alloc_list == NULL || alloc_Hp + n > alloc_HpLim) {
 299     if (small_alloc_list) {
 300       small_alloc_list->free = alloc_Hp;
 301     }
 302     bd = allocBlock();
 303     bd->link = small_alloc_list;
 304     small_alloc_list = bd;
 305     bd->gen = g0;
 306     bd->step = g0s0;
 307     bd->evacuated = 0;
 308     alloc_Hp = bd->start;
 309     alloc_HpLim = bd->start + BLOCK_SIZE_W;
 310     alloc_blocks++;
 311   }
 312
 313   p = alloc_Hp;
 314   alloc_Hp += n;
 315   return p;
 316 }
 317
 318 lnat allocated_bytes(void)
 319 {
 320   return (alloc_blocks * BLOCK_SIZE_W - (alloc_HpLim - alloc_Hp));
 321 }
 322
 323 /* -----------------------------------------------------------------------------
 324    Allocation functions for GMP.
 325
 326    These all use the allocate() interface - we can't have any garbage
 327    collection going on during a gmp operation, so we use allocate()
 328    which always succeeds.  The gmp operations which might need to
 329    allocate will ask the storage manager (via doYouWantToGC()) whether
 330    a garbage collection is required, in case we get into a loop doing
 331    only allocate() style allocation.
 332    -------------------------------------------------------------------------- */
 333
 334 static void *
 335 stgAllocForGMP (size_t size_in_bytes)
 336 {
 337   StgArrWords* arr;
 338   nat data_size_in_words, total_size_in_words;
 339
 340   /* should be a multiple of sizeof(StgWord) (whole no. of limbs) */
 341   ASSERT(size_in_bytes % sizeof(W_) == 0);
 342
 343   data_size_in_words  = size_in_bytes / sizeof(W_);
 344   total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
 345
 346   /* allocate and fill it in. */
 347   arr = (StgArrWords *)allocate(total_size_in_words);
 348   SET_ARR_HDR(arr, &ARR_WORDS_info, CCCS, data_size_in_words);
 349
 350   /* and return a ptr to the goods inside the array */
 351   return(BYTE_ARR_CTS(arr));
 352 }
 353
 354 static void *
 355 stgReallocForGMP (void *ptr, size_t old_size, size_t new_size)
 356 {
 357     void *new_stuff_ptr = stgAllocForGMP(new_size);
 358     nat i = 0;
 359     char *p = (char *) ptr;
 360     char *q = (char *) new_stuff_ptr;
 361
 362     for (; i < old_size; i++, p++, q++) {
 363         *q = *p;
 364     }
 365
 366     return(new_stuff_ptr);
 367 }
 368
 369 static void
 370 stgDeallocForGMP (void *ptr STG_UNUSED,
 371                   size_t size STG_UNUSED)
 372 {
 373     /* easy for us: the garbage collector does the dealloc'n */
 374 }
 375
 376 /* -----------------------------------------------------------------------------
 377    Stats and stuff
 378    -------------------------------------------------------------------------- */
 379
 380 /* Approximate the amount of live data in the heap.  To be called just
 381  * after garbage collection (see GarbageCollect()).
 382  */
 383 extern lnat
 384 calcLive(void)
 385 {
 386   nat g, s;
 387   lnat live = 0;
 388   step *step;
 389
 390   if (RtsFlags.GcFlags.generations == 1) {
 391     live = (g0s0->to_blocks - 1) * BLOCK_SIZE_W +
 392       ((lnat)g0s0->hp_bd->free - (lnat)g0s0->hp_bd->start) / sizeof(W_);
 393     return live;
 394   }
 395
 396   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 397     for (s = 0; s < generations[g].n_steps; s++) {
 398       /* approximate amount of live data (doesn't take into account slop
 399        * at end of each block).
 400        */
 401       if (g == 0 && s == 0) {
 402           continue;
 403       }
 404       step = &generations[g].steps[s];
 405       live += (step->n_blocks - 1) * BLOCK_SIZE_W +
 406         ((lnat)step->hp_bd->free - (lnat)step->hp_bd->start) / sizeof(W_);
 407     }
 408   }
 409   return live;
 410 }
 411
 412 /* Approximate the number of blocks that will be needed at the next
 413  * garbage collection.
 414  *
 415  * Assume: all data currently live will remain live.  Steps that will
 416  * be collected next time will therefore need twice as many blocks
 417  * since all the data will be copied.
 418  */
 419 extern lnat
 420 calcNeeded(void)
 421 {
 422   lnat needed = 0;
 423   nat g, s;
 424   step *step;
 425
 426   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 427     for (s = 0; s < generations[g].n_steps; s++) {
 428       if (g == 0 && s == 0) { continue; }
 429       step = &generations[g].steps[s];
 430       if (generations[g].steps[0].n_blocks > generations[g].max_blocks) {
 431         needed += 2 * step->n_blocks;
 432       } else {
 433         needed += step->n_blocks;
 434       }
 435     }
 436   }
 437   return needed;
 438 }
 439
 440 /* -----------------------------------------------------------------------------
 441    Debugging
 442
 443    memInventory() checks for memory leaks by counting up all the
 444    blocks we know about and comparing that to the number of blocks
 445    allegedly floating around in the system.
 446    -------------------------------------------------------------------------- */
 447
 448 #ifdef DEBUG
 449
 450 extern void
 451 memInventory(void)
 452 {
 453   nat g, s;
 454   step *step;
 455   bdescr *bd;
 456   lnat total_blocks = 0, free_blocks = 0;
 457
 458   /* count the blocks we current have */
 459
 460   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 461     for (s = 0; s < generations[g].n_steps; s++) {
 462       step = &generations[g].steps[s];
 463       total_blocks += step->n_blocks;
 464       if (RtsFlags.GcFlags.generations == 1) {
 465         /* two-space collector has a to-space too :-) */
 466         total_blocks += g0s0->to_blocks;
 467       }
 468       for (bd = step->large_objects; bd; bd = bd->link) {
 469         total_blocks += bd->blocks;
 470         /* hack for megablock groups: they have an extra block or two in
 471            the second and subsequent megablocks where the block
 472            descriptors would normally go.
 473         */
 474         if (bd->blocks > BLOCKS_PER_MBLOCK) {
 475           total_blocks -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
 476                           * bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE);
 477         }
 478       }
 479     }
 480   }
 481
 482   /* any blocks held by allocate() */
 483   for (bd = small_alloc_list; bd; bd = bd->link) {
 484     total_blocks += bd->blocks;
 485   }
 486   for (bd = large_alloc_list; bd; bd = bd->link) {
 487     total_blocks += bd->blocks;
 488   }
 489
 490   /* count the blocks on the free list */
 491   free_blocks = countFreeList();
 492
 493   ASSERT(total_blocks + free_blocks == mblocks_allocated * BLOCKS_PER_MBLOCK);
 494
 495 #if 0
 496   if (total_blocks + free_blocks != mblocks_allocated *
 497       BLOCKS_PER_MBLOCK) {
 498     fprintf(stderr, "Blocks: %ld live + %ld free  = %ld total (%ld around)\n",
 499             total_blocks, free_blocks, total_blocks + free_blocks,
 500             mblocks_allocated * BLOCKS_PER_MBLOCK);
 501   }
 502 #endif
 503 }
 504
 505 /* Full heap sanity check. */
 506
 507 extern void
 508 checkSanity(nat N)
 509 {
 510   nat g, s;
 511
 512   if (RtsFlags.GcFlags.generations == 1) {
 513     checkHeap(g0s0->to_space, NULL);
 514     checkChain(g0s0->large_objects);
 515   } else {
 516
 517     for (g = 0; g <= N; g++) {
 518       for (s = 0; s < generations[g].n_steps; s++) {
 519         if (g == 0 && s == 0) { continue; }
 520         checkHeap(generations[g].steps[s].blocks, NULL);
 521       }
 522     }
 523     for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
 524       for (s = 0; s < generations[g].n_steps; s++) {
 525         checkHeap(generations[g].steps[s].blocks,
 526                   generations[g].steps[s].blocks->start);
 527         checkChain(generations[g].steps[s].large_objects);
 528       }
 529     }
 530     checkFreeListSanity();
 531   }
 532 }
 533
 534 #endif