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