ghc/rts/Storage.c

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