ghc/rts/Storage.c

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