ghc/rts/Storage.c

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