ghc/rts/Storage.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Storage.c,v 1.78 2003/03/26 17:33:49 sof Exp $
   3  *
   4  * (c) The GHC Team, 1998-1999
   5  *
   6  * Storage manager front end
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #include "PosixSource.h"
  11 #include "Rts.h"
  12 #include "RtsUtils.h"
  13 #include "RtsFlags.h"
  14 #include "Stats.h"
  15 #include "Hooks.h"
  16 #include "BlockAlloc.h"
  17 #include "MBlock.h"
  18 #include "Weak.h"
  19 #include "Sanity.h"
  20 #include "Arena.h"
  21
  22 #include "Storage.h"
  23 #include "Schedule.h"
  24 #include "OSThreads.h"
  25 #include "StoragePriv.h"
  26
  27 #include "RetainerProfile.h"    // for counting memory blocks (memInventory)
  28
  29 #include <stdlib.h>
  30 #include <string.h>
  31
  32 StgClosure    *caf_list         = NULL;
  33
  34 bdescr *small_alloc_list;       /* allocate()d small objects */
  35 bdescr *pinned_object_block;    /* allocate pinned objects into this block */
  36 nat alloc_blocks;               /* number of allocate()d blocks since GC */
  37 nat alloc_blocks_lim;           /* approximate limit on alloc_blocks */
  38
  39 StgPtr alloc_Hp    = NULL;      /* next free byte in small_alloc_list */
  40 StgPtr alloc_HpLim = NULL;      /* end of block at small_alloc_list   */
  41
  42 generation *generations = NULL; /* all the generations */
  43 generation *g0          = NULL; /* generation 0, for convenience */
  44 generation *oldest_gen  = NULL; /* oldest generation, for convenience */
  45 step *g0s0              = NULL; /* generation 0, step 0, for convenience */
  46
  47 lnat total_allocated = 0;       /* total memory allocated during run */
  48
  49 /*
  50  * Storage manager mutex:  protects all the above state from
  51  * simultaneous access by two STG threads.
  52  */
  53 #ifdef SMP
  54 Mutex sm_mutex = INIT_MUTEX_VAR;
  55 #endif
  56
  57 /*
  58  * Forward references
  59  */
  60 static void *stgAllocForGMP   (size_t size_in_bytes);
  61 static void *stgReallocForGMP (void *ptr, size_t old_size, size_t new_size);
  62 static void  stgDeallocForGMP (void *ptr, size_t size);
  63
  64 void
  65 initStorage( void )
  66 {
  67   nat g, s;
  68   step *stp;
  69   generation *gen;
  70
  71   if (generations != NULL) {
  72       // multi-init protection
  73       return;
  74   }
  75
  76   /* Sanity check to make sure the LOOKS_LIKE_ macros appear to be
  77    * doing something reasonable.
  78    */
  79   ASSERT(LOOKS_LIKE_INFO_PTR(&stg_BLACKHOLE_info));
  80   ASSERT(LOOKS_LIKE_CLOSURE_PTR(&stg_dummy_ret_closure));
  81   ASSERT(!HEAP_ALLOCED(&stg_dummy_ret_closure));
  82
  83   if (RtsFlags.GcFlags.maxHeapSize != 0 &&
  84       RtsFlags.GcFlags.heapSizeSuggestion >
  85       RtsFlags.GcFlags.maxHeapSize) {
  86     RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion;
  87   }
  88
  89   if (RtsFlags.GcFlags.maxHeapSize != 0 &&
  90       RtsFlags.GcFlags.minAllocAreaSize >
  91       RtsFlags.GcFlags.maxHeapSize) {
  92       prog_belch("maximum heap size (-M) is smaller than minimum alloc area size (-A)");
  93       exit(1);
  94   }
  95
  96   initBlockAllocator();
  97
  98 #if defined(SMP)
  99   initMutex(&sm_mutex);
 100 #endif
 101
 102   /* allocate generation info array */
 103   generations = (generation *)stgMallocBytes(RtsFlags.GcFlags.generations
 104                                              * sizeof(struct _generation),
 105                                              "initStorage: gens");
 106
 107   /* Initialise all generations */
 108   for(g = 0; g < RtsFlags.GcFlags.generations; g++) {
 109     gen = &generations[g];
 110     gen->no = g;
 111     gen->mut_list = END_MUT_LIST;
 112     gen->mut_once_list = END_MUT_LIST;
 113     gen->collections = 0;
 114     gen->failed_promotions = 0;
 115     gen->max_blocks = 0;
 116   }
 117
 118   /* A couple of convenience pointers */
 119   g0 = &generations[0];
 120   oldest_gen = &generations[RtsFlags.GcFlags.generations-1];
 121
 122   /* Allocate step structures in each generation */
 123   if (RtsFlags.GcFlags.generations > 1) {
 124     /* Only for multiple-generations */
 125
 126     /* Oldest generation: one step */
 127     oldest_gen->n_steps = 1;
 128     oldest_gen->steps =
 129       stgMallocBytes(1 * sizeof(struct _step), "initStorage: last step");
 130
 131     /* set up all except the oldest generation with 2 steps */
 132     for(g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
 133       generations[g].n_steps = RtsFlags.GcFlags.steps;
 134       generations[g].steps  =
 135         stgMallocBytes (RtsFlags.GcFlags.steps * sizeof(struct _step),
 136                         "initStorage: steps");
 137     }
 138
 139   } else {
 140     /* single generation, i.e. a two-space collector */
 141     g0->n_steps = 1;
 142     g0->steps = stgMallocBytes (sizeof(struct _step), "initStorage: steps");
 143   }
 144
 145   /* Initialise all steps */
 146   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 147     for (s = 0; s < generations[g].n_steps; s++) {
 148       stp = &generations[g].steps[s];
 149       stp->no = s;
 150       stp->blocks = NULL;
 151       stp->n_to_blocks = 0;
 152       stp->n_blocks = 0;
 153       stp->gen = &generations[g];
 154       stp->gen_no = g;
 155       stp->hp = NULL;
 156       stp->hpLim = NULL;
 157       stp->hp_bd = NULL;
 158       stp->scan = NULL;
 159       stp->scan_bd = NULL;
 160       stp->large_objects = NULL;
 161       stp->n_large_blocks = 0;
 162       stp->new_large_objects = NULL;
 163       stp->scavenged_large_objects = NULL;
 164       stp->n_scavenged_large_blocks = 0;
 165       stp->is_compacted = 0;
 166       stp->bitmap = NULL;
 167     }
 168   }
 169
 170   /* Set up the destination pointers in each younger gen. step */
 171   for (g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
 172     for (s = 0; s < generations[g].n_steps-1; s++) {
 173       generations[g].steps[s].to = &generations[g].steps[s+1];
 174     }
 175     generations[g].steps[s].to = &generations[g+1].steps[0];
 176   }
 177
 178   /* The oldest generation has one step and it is compacted. */
 179   if (RtsFlags.GcFlags.compact) {
 180       if (RtsFlags.GcFlags.generations == 1) {
 181           belch("WARNING: compaction is incompatible with -G1; disabled");
 182       } else {
 183           oldest_gen->steps[0].is_compacted = 1;
 184       }
 185   }
 186   oldest_gen->steps[0].to = &oldest_gen->steps[0];
 187
 188   /* generation 0 is special: that's the nursery */
 189   generations[0].max_blocks = 0;
 190
 191   /* G0S0: the allocation area.  Policy: keep the allocation area
 192    * small to begin with, even if we have a large suggested heap
 193    * size.  Reason: we're going to do a major collection first, and we
 194    * don't want it to be a big one.  This vague idea is borne out by
 195    * rigorous experimental evidence.
 196    */
 197   g0s0 = &generations[0].steps[0];
 198
 199   allocNurseries();
 200
 201   weak_ptr_list = NULL;
 202   caf_list = NULL;
 203
 204   /* initialise the allocate() interface */
 205   small_alloc_list = NULL;
 206   alloc_blocks = 0;
 207   alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
 208
 209   /* Tell GNU multi-precision pkg about our custom alloc functions */
 210   mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);
 211
 212   IF_DEBUG(gc, statDescribeGens());
 213 }
 214
 215 void
 216 exitStorage (void)
 217 {
 218     stat_exit(calcAllocated());
 219 }
 220
 221 /* -----------------------------------------------------------------------------
 222    CAF management.
 223
 224    The entry code for every CAF does the following:
 225
 226       - builds a CAF_BLACKHOLE in the heap
 227       - pushes an update frame pointing to the CAF_BLACKHOLE
 228       - invokes UPD_CAF(), which:
 229           - calls newCaf, below
 230           - updates the CAF with a static indirection to the CAF_BLACKHOLE
 231
 232    Why do we build a BLACKHOLE in the heap rather than just updating
 233    the thunk directly?  It's so that we only need one kind of update
 234    frame - otherwise we'd need a static version of the update frame too.
 235
 236    newCaf() does the following:
 237
 238       - it puts the CAF on the oldest generation's mut-once list.
 239         This is so that we can treat the CAF as a root when collecting
 240         younger generations.
 241
 242    For GHCI, we have additional requirements when dealing with CAFs:
 243
 244       - we must *retain* all dynamically-loaded CAFs ever entered,
 245         just in case we need them again.
 246       - we must be able to *revert* CAFs that have been evaluated, to
 247         their pre-evaluated form.
 248
 249       To do this, we use an additional CAF list.  When newCaf() is
 250       called on a dynamically-loaded CAF, we add it to the CAF list
 251       instead of the old-generation mutable list, and save away its
 252       old info pointer (in caf->saved_info) for later reversion.
 253
 254       To revert all the CAFs, we traverse the CAF list and reset the
 255       info pointer to caf->saved_info, then throw away the CAF list.
 256       (see GC.c:revertCAFs()).
 257
 258       -- SDM 29/1/01
 259
 260    -------------------------------------------------------------------------- */
 261
 262 void
 263 newCAF(StgClosure* caf)
 264 {
 265   /* Put this CAF on the mutable list for the old generation.
 266    * This is a HACK - the IND_STATIC closure doesn't really have
 267    * a mut_link field, but we pretend it has - in fact we re-use
 268    * the STATIC_LINK field for the time being, because when we
 269    * come to do a major GC we won't need the mut_link field
 270    * any more and can use it as a STATIC_LINK.
 271    */
 272   ACQUIRE_SM_LOCK;
 273
 274   ((StgIndStatic *)caf)->saved_info = NULL;
 275   ((StgMutClosure *)caf)->mut_link = oldest_gen->mut_once_list;
 276   oldest_gen->mut_once_list = (StgMutClosure *)caf;
 277
 278   RELEASE_SM_LOCK;
 279
 280 #ifdef PAR
 281   /* If we are PAR or DIST then  we never forget a CAF */
 282   { globalAddr *newGA;
 283     //belch("<##> Globalising CAF %08x %s",caf,info_type(caf));
 284     newGA=makeGlobal(caf,rtsTrue); /*given full weight*/
 285     ASSERT(newGA);
 286   }
 287 #endif /* PAR */
 288 }
 289
 290 // An alternate version of newCaf which is used for dynamically loaded
 291 // object code in GHCi.  In this case we want to retain *all* CAFs in
 292 // the object code, because they might be demanded at any time from an
 293 // expression evaluated on the command line.
 294 //
 295 // The linker hackily arranges that references to newCaf from dynamic
 296 // code end up pointing to newDynCAF.
 297 void
 298 newDynCAF(StgClosure *caf)
 299 {
 300     ACQUIRE_SM_LOCK;
 301
 302     ((StgIndStatic *)caf)->saved_info  = (StgInfoTable *)caf->header.info;
 303     ((StgIndStatic *)caf)->static_link = caf_list;
 304     caf_list = caf;
 305
 306     RELEASE_SM_LOCK;
 307 }
 308
 309 /* -----------------------------------------------------------------------------
 310    Nursery management.
 311    -------------------------------------------------------------------------- */
 312
 313 void
 314 allocNurseries( void )
 315 {
 316 #ifdef SMP
 317   {
 318     Capability *cap;
 319     bdescr *bd;
 320
 321     g0s0->blocks = NULL;
 322     g0s0->n_blocks = 0;
 323     for (cap = free_capabilities; cap != NULL; cap = cap->link) {
 324       cap->r.rNursery = allocNursery(NULL, RtsFlags.GcFlags.minAllocAreaSize);
 325       cap->r.rCurrentNursery = cap->r.rNursery;
 326       for (bd = cap->r.rNursery; bd != NULL; bd = bd->link) {
 327         bd->u.back = (bdescr *)cap;
 328       }
 329     }
 330     /* Set the back links to be equal to the Capability,
 331      * so we can do slightly better informed locking.
 332      */
 333   }
 334 #else /* SMP */
 335   g0s0->blocks      = allocNursery(NULL, RtsFlags.GcFlags.minAllocAreaSize);
 336   g0s0->n_blocks    = RtsFlags.GcFlags.minAllocAreaSize;
 337   g0s0->to_blocks   = NULL;
 338   g0s0->n_to_blocks = 0;
 339   MainCapability.r.rNursery        = g0s0->blocks;
 340   MainCapability.r.rCurrentNursery = g0s0->blocks;
 341   /* hp, hpLim, hp_bd, to_space etc. aren't used in G0S0 */
 342 #endif
 343 }
 344
 345 void
 346 resetNurseries( void )
 347 {
 348   bdescr *bd;
 349 #ifdef SMP
 350   Capability *cap;
 351
 352   /* All tasks must be stopped */
 353   ASSERT(n_free_capabilities == RtsFlags.ParFlags.nNodes);
 354
 355   for (cap = free_capabilities; cap != NULL; cap = cap->link) {
 356     for (bd = cap->r.rNursery; bd; bd = bd->link) {
 357       bd->free = bd->start;
 358       ASSERT(bd->gen_no == 0);
 359       ASSERT(bd->step == g0s0);
 360       IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
 361     }
 362     cap->r.rCurrentNursery = cap->r.rNursery;
 363   }
 364 #else
 365   for (bd = g0s0->blocks; bd; bd = bd->link) {
 366     bd->free = bd->start;
 367     ASSERT(bd->gen_no == 0);
 368     ASSERT(bd->step == g0s0);
 369     IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
 370   }
 371   MainCapability.r.rNursery = g0s0->blocks;
 372   MainCapability.r.rCurrentNursery = g0s0->blocks;
 373 #endif
 374 }
 375
 376 bdescr *
 377 allocNursery (bdescr *tail, nat blocks)
 378 {
 379   bdescr *bd;
 380   nat i;
 381
 382   // Allocate a nursery: we allocate fresh blocks one at a time and
 383   // cons them on to the front of the list, not forgetting to update
 384   // the back pointer on the tail of the list to point to the new block.
 385   for (i=0; i < blocks; i++) {
 386     // @LDV profiling
 387     /*
 388       processNursery() in LdvProfile.c assumes that every block group in
 389       the nursery contains only a single block. So, if a block group is
 390       given multiple blocks, change processNursery() accordingly.
 391      */
 392     bd = allocBlock();
 393     bd->link = tail;
 394     // double-link the nursery: we might need to insert blocks
 395     if (tail != NULL) {
 396         tail->u.back = bd;
 397     }
 398     bd->step = g0s0;
 399     bd->gen_no = 0;
 400     bd->flags = 0;
 401     bd->free = bd->start;
 402     tail = bd;
 403   }
 404   tail->u.back = NULL;
 405   return tail;
 406 }
 407
 408 void
 409 resizeNursery ( nat blocks )
 410 {
 411   bdescr *bd;
 412   nat nursery_blocks;
 413
 414 #ifdef SMP
 415   barf("resizeNursery: can't resize in SMP mode");
 416 #endif
 417
 418   nursery_blocks = g0s0->n_blocks;
 419   if (nursery_blocks == blocks) {
 420     return;
 421   }
 422
 423   else if (nursery_blocks < blocks) {
 424     IF_DEBUG(gc, fprintf(stderr, "Increasing size of nursery to %d blocks\n",
 425                          blocks));
 426     g0s0->blocks = allocNursery(g0s0->blocks, blocks-nursery_blocks);
 427   }
 428
 429   else {
 430     bdescr *next_bd;
 431
 432     IF_DEBUG(gc, fprintf(stderr, "Decreasing size of nursery to %d blocks\n",
 433                          blocks));
 434
 435     bd = g0s0->blocks;
 436     while (nursery_blocks > blocks) {
 437         next_bd = bd->link;
 438         next_bd->u.back = NULL;
 439         nursery_blocks -= bd->blocks; // might be a large block
 440         freeGroup(bd);
 441         bd = next_bd;
 442     }
 443     g0s0->blocks = bd;
 444     // might have gone just under, by freeing a large block, so make
 445     // up the difference.
 446     if (nursery_blocks < blocks) {
 447         g0s0->blocks = allocNursery(g0s0->blocks, blocks-nursery_blocks);
 448     }
 449   }
 450
 451   g0s0->n_blocks = blocks;
 452   ASSERT(countBlocks(g0s0->blocks) == g0s0->n_blocks);
 453 }
 454
 455 /* -----------------------------------------------------------------------------
 456    The allocate() interface
 457
 458    allocate(n) always succeeds, and returns a chunk of memory n words
 459    long.  n can be larger than the size of a block if necessary, in
 460    which case a contiguous block group will be allocated.
 461    -------------------------------------------------------------------------- */
 462
 463 StgPtr
 464 allocate( nat n )
 465 {
 466   bdescr *bd;
 467   StgPtr p;
 468
 469   ACQUIRE_SM_LOCK;
 470
 471   TICK_ALLOC_HEAP_NOCTR(n);
 472   CCS_ALLOC(CCCS,n);
 473
 474   /* big allocation (>LARGE_OBJECT_THRESHOLD) */
 475   /* ToDo: allocate directly into generation 1 */
 476   if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
 477     nat req_blocks =  (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
 478     bd = allocGroup(req_blocks);
 479     dbl_link_onto(bd, &g0s0->large_objects);
 480     bd->gen_no  = 0;
 481     bd->step = g0s0;
 482     bd->flags = BF_LARGE;
 483     bd->free = bd->start + n;
 484     /* don't add these blocks to alloc_blocks, since we're assuming
 485      * that large objects are likely to remain live for quite a while
 486      * (eg. running threads), so garbage collecting early won't make
 487      * much difference.
 488      */
 489     alloc_blocks += req_blocks;
 490     RELEASE_SM_LOCK;
 491     return bd->start;
 492
 493   /* small allocation (<LARGE_OBJECT_THRESHOLD) */
 494   } else if (small_alloc_list == NULL || alloc_Hp + n > alloc_HpLim) {
 495     if (small_alloc_list) {
 496       small_alloc_list->free = alloc_Hp;
 497     }
 498     bd = allocBlock();
 499     bd->link = small_alloc_list;
 500     small_alloc_list = bd;
 501     bd->gen_no = 0;
 502     bd->step = g0s0;
 503     bd->flags = 0;
 504     alloc_Hp = bd->start;
 505     alloc_HpLim = bd->start + BLOCK_SIZE_W;
 506     alloc_blocks++;
 507   }
 508
 509   p = alloc_Hp;
 510   alloc_Hp += n;
 511   RELEASE_SM_LOCK;
 512   return p;
 513 }
 514
 515 lnat
 516 allocated_bytes( void )
 517 {
 518     lnat allocated;
 519
 520     allocated = alloc_blocks * BLOCK_SIZE_W - (alloc_HpLim - alloc_Hp);
 521     if (pinned_object_block != NULL) {
 522         allocated -= (pinned_object_block->start + BLOCK_SIZE_W) -
 523             pinned_object_block->free;
 524     }
 525
 526     return allocated;
 527 }
 528
 529 void
 530 tidyAllocateLists (void)
 531 {
 532     if (small_alloc_list != NULL) {
 533         ASSERT(alloc_Hp >= small_alloc_list->start &&
 534                alloc_Hp <= small_alloc_list->start + BLOCK_SIZE);
 535         small_alloc_list->free = alloc_Hp;
 536     }
 537 }
 538
 539 /* ---------------------------------------------------------------------------
 540    Allocate a fixed/pinned object.
 541
 542    We allocate small pinned objects into a single block, allocating a
 543    new block when the current one overflows.  The block is chained
 544    onto the large_object_list of generation 0 step 0.
 545
 546    NOTE: The GC can't in general handle pinned objects.  This
 547    interface is only safe to use for ByteArrays, which have no
 548    pointers and don't require scavenging.  It works because the
 549    block's descriptor has the BF_LARGE flag set, so the block is
 550    treated as a large object and chained onto various lists, rather
 551    than the individual objects being copied.  However, when it comes
 552    to scavenge the block, the GC will only scavenge the first object.
 553    The reason is that the GC can't linearly scan a block of pinned
 554    objects at the moment (doing so would require using the
 555    mostly-copying techniques).  But since we're restricting ourselves
 556    to pinned ByteArrays, not scavenging is ok.
 557
 558    This function is called by newPinnedByteArray# which immediately
 559    fills the allocated memory with a MutableByteArray#.
 560    ------------------------------------------------------------------------- */
 561
 562 StgPtr
 563 allocatePinned( nat n )
 564 {
 565     StgPtr p;
 566     bdescr *bd = pinned_object_block;
 567
 568     ACQUIRE_SM_LOCK;
 569
 570     TICK_ALLOC_HEAP_NOCTR(n);
 571     CCS_ALLOC(CCCS,n);
 572
 573     // If the request is for a large object, then allocate()
 574     // will give us a pinned object anyway.
 575     if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
 576         RELEASE_SM_LOCK;
 577         return allocate(n);
 578     }
 579
 580     // we always return 8-byte aligned memory.  bd->free must be
 581     // 8-byte aligned to begin with, so we just round up n to
 582     // the nearest multiple of 8 bytes.
 583     if (sizeof(StgWord) == 4) {
 584         n = (n+1) & ~1;
 585     }
 586
 587     // If we don't have a block of pinned objects yet, or the current
 588     // one isn't large enough to hold the new object, allocate a new one.
 589     if (bd == NULL || (bd->free + n) > (bd->start + BLOCK_SIZE_W)) {
 590         pinned_object_block = bd = allocBlock();
 591         dbl_link_onto(bd, &g0s0->large_objects);
 592         bd->gen_no = 0;
 593         bd->step   = g0s0;
 594         bd->flags  = BF_LARGE;
 595         bd->free   = bd->start;
 596         alloc_blocks++;
 597     }
 598
 599     p = bd->free;
 600     bd->free += n;
 601     RELEASE_SM_LOCK;
 602     return p;
 603 }
 604
 605 /* -----------------------------------------------------------------------------
 606    Allocation functions for GMP.
 607
 608    These all use the allocate() interface - we can't have any garbage
 609    collection going on during a gmp operation, so we use allocate()
 610    which always succeeds.  The gmp operations which might need to
 611    allocate will ask the storage manager (via doYouWantToGC()) whether
 612    a garbage collection is required, in case we get into a loop doing
 613    only allocate() style allocation.
 614    -------------------------------------------------------------------------- */
 615
 616 static void *
 617 stgAllocForGMP (size_t size_in_bytes)
 618 {
 619   StgArrWords* arr;
 620   nat data_size_in_words, total_size_in_words;
 621
 622   /* round up to a whole number of words */
 623   data_size_in_words  = (size_in_bytes + sizeof(W_) + 1) / sizeof(W_);
 624   total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
 625
 626   /* allocate and fill it in. */
 627   arr = (StgArrWords *)allocate(total_size_in_words);
 628   SET_ARR_HDR(arr, &stg_ARR_WORDS_info, CCCS, data_size_in_words);
 629
 630   /* and return a ptr to the goods inside the array */
 631   return(BYTE_ARR_CTS(arr));
 632 }
 633
 634 static void *
 635 stgReallocForGMP (void *ptr, size_t old_size, size_t new_size)
 636 {
 637     void *new_stuff_ptr = stgAllocForGMP(new_size);
 638     nat i = 0;
 639     char *p = (char *) ptr;
 640     char *q = (char *) new_stuff_ptr;
 641
 642     for (; i < old_size; i++, p++, q++) {
 643         *q = *p;
 644     }
 645
 646     return(new_stuff_ptr);
 647 }
 648
 649 static void
 650 stgDeallocForGMP (void *ptr STG_UNUSED,
 651                   size_t size STG_UNUSED)
 652 {
 653     /* easy for us: the garbage collector does the dealloc'n */
 654 }
 655
 656 /* -----------------------------------------------------------------------------
 657  * Stats and stuff
 658  * -------------------------------------------------------------------------- */
 659
 660 /* -----------------------------------------------------------------------------
 661  * calcAllocated()
 662  *
 663  * Approximate how much we've allocated: number of blocks in the
 664  * nursery + blocks allocated via allocate() - unused nusery blocks.
 665  * This leaves a little slop at the end of each block, and doesn't
 666  * take into account large objects (ToDo).
 667  * -------------------------------------------------------------------------- */
 668
 669 lnat
 670 calcAllocated( void )
 671 {
 672   nat allocated;
 673   bdescr *bd;
 674
 675 #ifdef SMP
 676   Capability *cap;
 677
 678   /* All tasks must be stopped.  Can't assert that all the
 679      capabilities are owned by the scheduler, though: one or more
 680      tasks might have been stopped while they were running (non-main)
 681      threads. */
 682   /*  ASSERT(n_free_capabilities == RtsFlags.ParFlags.nNodes); */
 683
 684   allocated =
 685     n_free_capabilities * RtsFlags.GcFlags.minAllocAreaSize * BLOCK_SIZE_W
 686     + allocated_bytes();
 687
 688   for (cap = free_capabilities; cap != NULL; cap = cap->link) {
 689     for ( bd = cap->r.rCurrentNursery->link; bd != NULL; bd = bd->link ) {
 690       allocated -= BLOCK_SIZE_W;
 691     }
 692     if (cap->r.rCurrentNursery->free < cap->r.rCurrentNursery->start
 693         + BLOCK_SIZE_W) {
 694       allocated -= (cap->r.rCurrentNursery->start + BLOCK_SIZE_W)
 695         - cap->r.rCurrentNursery->free;
 696     }
 697   }
 698
 699 #else /* !SMP */
 700   bdescr *current_nursery = MainCapability.r.rCurrentNursery;
 701
 702   allocated = (g0s0->n_blocks * BLOCK_SIZE_W) + allocated_bytes();
 703   for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
 704     allocated -= BLOCK_SIZE_W;
 705   }
 706   if (current_nursery->free < current_nursery->start + BLOCK_SIZE_W) {
 707     allocated -= (current_nursery->start + BLOCK_SIZE_W)
 708       - current_nursery->free;
 709   }
 710 #endif
 711
 712   total_allocated += allocated;
 713   return allocated;
 714 }
 715
 716 /* Approximate the amount of live data in the heap.  To be called just
 717  * after garbage collection (see GarbageCollect()).
 718  */
 719 extern lnat
 720 calcLive(void)
 721 {
 722   nat g, s;
 723   lnat live = 0;
 724   step *stp;
 725
 726   if (RtsFlags.GcFlags.generations == 1) {
 727     live = (g0s0->n_to_blocks - 1) * BLOCK_SIZE_W +
 728       ((lnat)g0s0->hp_bd->free - (lnat)g0s0->hp_bd->start) / sizeof(W_);
 729     return live;
 730   }
 731
 732   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 733     for (s = 0; s < generations[g].n_steps; s++) {
 734       /* approximate amount of live data (doesn't take into account slop
 735        * at end of each block).
 736        */
 737       if (g == 0 && s == 0) {
 738           continue;
 739       }
 740       stp = &generations[g].steps[s];
 741       live += (stp->n_large_blocks + stp->n_blocks - 1) * BLOCK_SIZE_W;
 742       if (stp->hp_bd != NULL) {
 743           live += ((lnat)stp->hp_bd->free - (lnat)stp->hp_bd->start)
 744               / sizeof(W_);
 745       }
 746     }
 747   }
 748   return live;
 749 }
 750
 751 /* Approximate the number of blocks that will be needed at the next
 752  * garbage collection.
 753  *
 754  * Assume: all data currently live will remain live.  Steps that will
 755  * be collected next time will therefore need twice as many blocks
 756  * since all the data will be copied.
 757  */
 758 extern lnat
 759 calcNeeded(void)
 760 {
 761     lnat needed = 0;
 762     nat g, s;
 763     step *stp;
 764
 765     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 766         for (s = 0; s < generations[g].n_steps; s++) {
 767             if (g == 0 && s == 0) { continue; }
 768             stp = &generations[g].steps[s];
 769             if (generations[g].steps[0].n_blocks +
 770                 generations[g].steps[0].n_large_blocks
 771                 > generations[g].max_blocks
 772                 && stp->is_compacted == 0) {
 773                 needed += 2 * stp->n_blocks;
 774             } else {
 775                 needed += stp->n_blocks;
 776             }
 777         }
 778     }
 779     return needed;
 780 }
 781
 782 /* -----------------------------------------------------------------------------
 783    Debugging
 784
 785    memInventory() checks for memory leaks by counting up all the
 786    blocks we know about and comparing that to the number of blocks
 787    allegedly floating around in the system.
 788    -------------------------------------------------------------------------- */
 789
 790 #ifdef DEBUG
 791
 792 void
 793 memInventory(void)
 794 {
 795   nat g, s;
 796   step *stp;
 797   bdescr *bd;
 798   lnat total_blocks = 0, free_blocks = 0;
 799
 800   /* count the blocks we current have */
 801
 802   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 803     for (s = 0; s < generations[g].n_steps; s++) {
 804       stp = &generations[g].steps[s];
 805       total_blocks += stp->n_blocks;
 806       if (RtsFlags.GcFlags.generations == 1) {
 807         /* two-space collector has a to-space too :-) */
 808         total_blocks += g0s0->n_to_blocks;
 809       }
 810       for (bd = stp->large_objects; bd; bd = bd->link) {
 811         total_blocks += bd->blocks;
 812         /* hack for megablock groups: they have an extra block or two in
 813            the second and subsequent megablocks where the block
 814            descriptors would normally go.
 815         */
 816         if (bd->blocks > BLOCKS_PER_MBLOCK) {
 817           total_blocks -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
 818                           * (bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE));
 819         }
 820       }
 821     }
 822   }
 823
 824   /* any blocks held by allocate() */
 825   for (bd = small_alloc_list; bd; bd = bd->link) {
 826     total_blocks += bd->blocks;
 827   }
 828
 829 #ifdef PROFILING
 830   if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_RETAINER) {
 831       total_blocks += retainerStackBlocks();
 832   }
 833 #endif
 834
 835   // count the blocks allocated by the arena allocator
 836   total_blocks += arenaBlocks();
 837
 838   /* count the blocks on the free list */
 839   free_blocks = countFreeList();
 840
 841   if (total_blocks + free_blocks != mblocks_allocated *
 842       BLOCKS_PER_MBLOCK) {
 843     fprintf(stderr, "Blocks: %ld live + %ld free  = %ld total (%ld around)\n",
 844             total_blocks, free_blocks, total_blocks + free_blocks,
 845             mblocks_allocated * BLOCKS_PER_MBLOCK);
 846   }
 847
 848   ASSERT(total_blocks + free_blocks == mblocks_allocated * BLOCKS_PER_MBLOCK);
 849 }
 850
 851
 852 nat
 853 countBlocks(bdescr *bd)
 854 {
 855     nat n;
 856     for (n=0; bd != NULL; bd=bd->link) {
 857         n += bd->blocks;
 858     }
 859     return n;
 860 }
 861
 862 /* Full heap sanity check. */
 863 void
 864 checkSanity( void )
 865 {
 866     nat g, s;
 867
 868     if (RtsFlags.GcFlags.generations == 1) {
 869         checkHeap(g0s0->to_blocks);
 870         checkChain(g0s0->large_objects);
 871     } else {
 872
 873         for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 874             for (s = 0; s < generations[g].n_steps; s++) {
 875                 ASSERT(countBlocks(generations[g].steps[s].blocks)
 876                        == generations[g].steps[s].n_blocks);
 877                 ASSERT(countBlocks(generations[g].steps[s].large_objects)
 878                        == generations[g].steps[s].n_large_blocks);
 879                 if (g == 0 && s == 0) { continue; }
 880                 checkHeap(generations[g].steps[s].blocks);
 881                 checkChain(generations[g].steps[s].large_objects);
 882                 if (g > 0) {
 883                     checkMutableList(generations[g].mut_list, g);
 884                     checkMutOnceList(generations[g].mut_once_list, g);
 885                 }
 886             }
 887         }
 888         checkFreeListSanity();
 889     }
 890 }
 891
 892 // handy function for use in gdb, because Bdescr() is inlined.
 893 extern bdescr *_bdescr( StgPtr p );
 894
 895 bdescr *
 896 _bdescr( StgPtr p )
 897 {
 898     return Bdescr(p);
 899 }
 900
 901 #endif