rts/sm/Storage.c

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