ghc/rts/Storage.c

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