ghc/rts/Storage.c

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