ghc/rts/Storage.c

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