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