ghc/rts/Storage.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Storage.c,v 1.17 1999/03/16 13:20:18 simonm 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 #if 0
 258     STATIC_LINK2(info,caf) = caf_list;
 259     caf_list = caf;
 260 #endif
 261   }
 262 #endif
 263 }
 264
 265 /* -----------------------------------------------------------------------------
 266    The allocate() interface
 267
 268    allocate(n) always succeeds, and returns a chunk of memory n words
 269    long.  n can be larger than the size of a block if necessary, in
 270    which case a contiguous block group will be allocated.
 271    -------------------------------------------------------------------------- */
 272
 273 StgPtr
 274 allocate(nat n)
 275 {
 276   bdescr *bd;
 277   StgPtr p;
 278
 279   TICK_ALLOC_HEAP(n);
 280   CCS_ALLOC(CCCS,n);
 281
 282   /* big allocation (>LARGE_OBJECT_THRESHOLD) */
 283   /* ToDo: allocate directly into generation 1 */
 284   if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
 285     nat req_blocks =  (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
 286     bd = allocGroup(req_blocks);
 287     dbl_link_onto(bd, &g0s0->large_objects);
 288     bd->gen  = g0;
 289     bd->step = g0s0;
 290     bd->evacuated = 0;
 291     bd->free = bd->start;
 292     /* don't add these blocks to alloc_blocks, since we're assuming
 293      * that large objects are likely to remain live for quite a while
 294      * (eg. running threads), so garbage collecting early won't make
 295      * much difference.
 296      */
 297     return bd->start;
 298
 299   /* small allocation (<LARGE_OBJECT_THRESHOLD) */
 300   } else if (small_alloc_list == NULL || alloc_Hp + n > alloc_HpLim) {
 301     if (small_alloc_list) {
 302       small_alloc_list->free = alloc_Hp;
 303     }
 304     bd = allocBlock();
 305     bd->link = small_alloc_list;
 306     small_alloc_list = bd;
 307     bd->gen = g0;
 308     bd->step = g0s0;
 309     bd->evacuated = 0;
 310     alloc_Hp = bd->start;
 311     alloc_HpLim = bd->start + BLOCK_SIZE_W;
 312     alloc_blocks++;
 313   }
 314
 315   p = alloc_Hp;
 316   alloc_Hp += n;
 317   return p;
 318 }
 319
 320 lnat allocated_bytes(void)
 321 {
 322   return (alloc_blocks * BLOCK_SIZE_W - (alloc_HpLim - alloc_Hp));
 323 }
 324
 325 /* -----------------------------------------------------------------------------
 326    Allocation functions for GMP.
 327
 328    These all use the allocate() interface - we can't have any garbage
 329    collection going on during a gmp operation, so we use allocate()
 330    which always succeeds.  The gmp operations which might need to
 331    allocate will ask the storage manager (via doYouWantToGC()) whether
 332    a garbage collection is required, in case we get into a loop doing
 333    only allocate() style allocation.
 334    -------------------------------------------------------------------------- */
 335
 336 static void *
 337 stgAllocForGMP (size_t size_in_bytes)
 338 {
 339   StgArrWords* arr;
 340   nat data_size_in_words, total_size_in_words;
 341
 342   /* should be a multiple of sizeof(StgWord) (whole no. of limbs) */
 343   ASSERT(size_in_bytes % sizeof(W_) == 0);
 344
 345   data_size_in_words  = size_in_bytes / sizeof(W_);
 346   total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
 347
 348   /* allocate and fill it in. */
 349   arr = (StgArrWords *)allocate(total_size_in_words);
 350   SET_ARR_HDR(arr, &ARR_WORDS_info, CCCS, data_size_in_words);
 351
 352   /* and return a ptr to the goods inside the array */
 353   return(BYTE_ARR_CTS(arr));
 354 }
 355
 356 static void *
 357 stgReallocForGMP (void *ptr, size_t old_size, size_t new_size)
 358 {
 359     void *new_stuff_ptr = stgAllocForGMP(new_size);
 360     nat i = 0;
 361     char *p = (char *) ptr;
 362     char *q = (char *) new_stuff_ptr;
 363
 364     for (; i < old_size; i++, p++, q++) {
 365         *q = *p;
 366     }
 367
 368     return(new_stuff_ptr);
 369 }
 370
 371 static void
 372 stgDeallocForGMP (void *ptr STG_UNUSED,
 373                   size_t size STG_UNUSED)
 374 {
 375     /* easy for us: the garbage collector does the dealloc'n */
 376 }
 377
 378 /* -----------------------------------------------------------------------------
 379    Stats and stuff
 380    -------------------------------------------------------------------------- */
 381
 382 /* Approximate the amount of live data in the heap.  To be called just
 383  * after garbage collection (see GarbageCollect()).
 384  */
 385 extern lnat
 386 calcLive(void)
 387 {
 388   nat g, s;
 389   lnat live = 0;
 390   step *step;
 391
 392   if (RtsFlags.GcFlags.generations == 1) {
 393     live = (g0s0->to_blocks - 1) * BLOCK_SIZE_W +
 394       ((lnat)g0s0->hp_bd->free - (lnat)g0s0->hp_bd->start) / sizeof(W_);
 395     return live;
 396   }
 397
 398   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 399     for (s = 0; s < generations[g].n_steps; s++) {
 400       /* approximate amount of live data (doesn't take into account slop
 401        * at end of each block).
 402        */
 403       if (g == 0 && s == 0) {
 404           continue;
 405       }
 406       step = &generations[g].steps[s];
 407       live += (step->n_blocks - 1) * BLOCK_SIZE_W +
 408         ((lnat)step->hp_bd->free - (lnat)step->hp_bd->start) / sizeof(W_);
 409     }
 410   }
 411   return live;
 412 }
 413
 414 /* Approximate the number of blocks that will be needed at the next
 415  * garbage collection.
 416  *
 417  * Assume: all data currently live will remain live.  Steps that will
 418  * be collected next time will therefore need twice as many blocks
 419  * since all the data will be copied.
 420  */
 421 extern lnat
 422 calcNeeded(void)
 423 {
 424   lnat needed = 0;
 425   nat g, s;
 426   step *step;
 427
 428   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 429     for (s = 0; s < generations[g].n_steps; s++) {
 430       if (g == 0 && s == 0) { continue; }
 431       step = &generations[g].steps[s];
 432       if (generations[g].steps[0].n_blocks > generations[g].max_blocks) {
 433         needed += 2 * step->n_blocks;
 434       } else {
 435         needed += step->n_blocks;
 436       }
 437     }
 438   }
 439   return needed;
 440 }
 441
 442 /* -----------------------------------------------------------------------------
 443    Debugging
 444
 445    memInventory() checks for memory leaks by counting up all the
 446    blocks we know about and comparing that to the number of blocks
 447    allegedly floating around in the system.
 448    -------------------------------------------------------------------------- */
 449
 450 #ifdef DEBUG
 451
 452 extern void
 453 memInventory(void)
 454 {
 455   nat g, s;
 456   step *step;
 457   bdescr *bd;
 458   lnat total_blocks = 0, free_blocks = 0;
 459
 460   /* count the blocks we current have */
 461
 462   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 463     for (s = 0; s < generations[g].n_steps; s++) {
 464       step = &generations[g].steps[s];
 465       total_blocks += step->n_blocks;
 466       if (RtsFlags.GcFlags.generations == 1) {
 467         /* two-space collector has a to-space too :-) */
 468         total_blocks += g0s0->to_blocks;
 469       }
 470       for (bd = step->large_objects; bd; bd = bd->link) {
 471         total_blocks += bd->blocks;
 472         /* hack for megablock groups: they have an extra block or two in
 473            the second and subsequent megablocks where the block
 474            descriptors would normally go.
 475         */
 476         if (bd->blocks > BLOCKS_PER_MBLOCK) {
 477           total_blocks -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
 478                           * bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE);
 479         }
 480       }
 481     }
 482   }
 483
 484   /* any blocks held by allocate() */
 485   for (bd = small_alloc_list; bd; bd = bd->link) {
 486     total_blocks += bd->blocks;
 487   }
 488   for (bd = large_alloc_list; bd; bd = bd->link) {
 489     total_blocks += bd->blocks;
 490   }
 491
 492   /* count the blocks on the free list */
 493   free_blocks = countFreeList();
 494
 495   ASSERT(total_blocks + free_blocks == mblocks_allocated * BLOCKS_PER_MBLOCK);
 496
 497 #if 0
 498   if (total_blocks + free_blocks != mblocks_allocated *
 499       BLOCKS_PER_MBLOCK) {
 500     fprintf(stderr, "Blocks: %ld live + %ld free  = %ld total (%ld around)\n",
 501             total_blocks, free_blocks, total_blocks + free_blocks,
 502             mblocks_allocated * BLOCKS_PER_MBLOCK);
 503   }
 504 #endif
 505 }
 506
 507 /* Full heap sanity check. */
 508
 509 extern void
 510 checkSanity(nat N)
 511 {
 512   nat g, s;
 513
 514   if (RtsFlags.GcFlags.generations == 1) {
 515     checkHeap(g0s0->to_space, NULL);
 516     checkChain(g0s0->large_objects);
 517   } else {
 518
 519     for (g = 0; g <= N; g++) {
 520       for (s = 0; s < generations[g].n_steps; s++) {
 521         if (g == 0 && s == 0) { continue; }
 522         checkHeap(generations[g].steps[s].blocks, NULL);
 523       }
 524     }
 525     for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
 526       for (s = 0; s < generations[g].n_steps; s++) {
 527         checkHeap(generations[g].steps[s].blocks,
 528                   generations[g].steps[s].blocks->start);
 529         checkChain(generations[g].steps[s].large_objects);
 530       }
 531     }
 532     checkFreeListSanity();
 533   }
 534 }
 535
 536 #endif