ghc/rts/Storage.c

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