ghc/rts/Storage.c

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