ghc/rts/Storage.c

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