ghc/rts/Storage.c

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