ghc/rts/Storage.c

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