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 #endif
 291 }
 292
 293 /* -----------------------------------------------------------------------------
 294    CAF management.
 295
 296    The entry code for every CAF does the following:
 297
 298       - builds a CAF_BLACKHOLE in the heap
 299       - pushes an update frame pointing to the CAF_BLACKHOLE
 300       - invokes UPD_CAF(), which:
 301           - calls newCaf, below
 302           - updates the CAF with a static indirection to the CAF_BLACKHOLE
 303
 304    Why do we build a BLACKHOLE in the heap rather than just updating
 305    the thunk directly?  It's so that we only need one kind of update
 306    frame - otherwise we'd need a static version of the update frame too.
 307
 308    newCaf() does the following:
 309
 310       - it puts the CAF on the oldest generation's mut-once list.
 311         This is so that we can treat the CAF as a root when collecting
 312         younger generations.
 313
 314    For GHCI, we have additional requirements when dealing with CAFs:
 315
 316       - we must *retain* all dynamically-loaded CAFs ever entered,
 317         just in case we need them again.
 318       - we must be able to *revert* CAFs that have been evaluated, to
 319         their pre-evaluated form.
 320
 321       To do this, we use an additional CAF list.  When newCaf() is
 322       called on a dynamically-loaded CAF, we add it to the CAF list
 323       instead of the old-generation mutable list, and save away its
 324       old info pointer (in caf->saved_info) for later reversion.
 325
 326       To revert all the CAFs, we traverse the CAF list and reset the
 327       info pointer to caf->saved_info, then throw away the CAF list.
 328       (see GC.c:revertCAFs()).
 329
 330       -- SDM 29/1/01
 331
 332    -------------------------------------------------------------------------- */
 333
 334 void
 335 newCAF(StgClosure* caf)
 336 {
 337   ACQUIRE_SM_LOCK;
 338
 339   if(keepCAFs)
 340   {
 341     // HACK:
 342     // If we are in GHCi _and_ we are using dynamic libraries,
 343     // then we can't redirect newCAF calls to newDynCAF (see below),
 344     // so we make newCAF behave almost like newDynCAF.
 345     // The dynamic libraries might be used by both the interpreted
 346     // program and GHCi itself, so they must not be reverted.
 347     // This also means that in GHCi with dynamic libraries, CAFs are not
 348     // garbage collected. If this turns out to be a problem, we could
 349     // do another hack here and do an address range test on caf to figure
 350     // out whether it is from a dynamic library.
 351     ((StgIndStatic *)caf)->saved_info  = (StgInfoTable *)caf->header.info;
 352     ((StgIndStatic *)caf)->static_link = caf_list;
 353     caf_list = caf;
 354   }
 355   else
 356   {
 357     /* Put this CAF on the mutable list for the old generation.
 358     * This is a HACK - the IND_STATIC closure doesn't really have
 359     * a mut_link field, but we pretend it has - in fact we re-use
 360     * the STATIC_LINK field for the time being, because when we
 361     * come to do a major GC we won't need the mut_link field
 362     * any more and can use it as a STATIC_LINK.
 363     */
 364     ((StgIndStatic *)caf)->saved_info = NULL;
 365     recordMutableGen(caf, oldest_gen);
 366   }
 367
 368   RELEASE_SM_LOCK;
 369 }
 370
 371 // An alternate version of newCaf which is used for dynamically loaded
 372 // object code in GHCi.  In this case we want to retain *all* CAFs in
 373 // the object code, because they might be demanded at any time from an
 374 // expression evaluated on the command line.
 375 // Also, GHCi might want to revert CAFs, so we add these to the
 376 // revertible_caf_list.
 377 //
 378 // The linker hackily arranges that references to newCaf from dynamic
 379 // code end up pointing to newDynCAF.
 380 void
 381 newDynCAF(StgClosure *caf)
 382 {
 383     ACQUIRE_SM_LOCK;
 384
 385     ((StgIndStatic *)caf)->saved_info  = (StgInfoTable *)caf->header.info;
 386     ((StgIndStatic *)caf)->static_link = revertible_caf_list;
 387     revertible_caf_list = caf;
 388
 389     RELEASE_SM_LOCK;
 390 }
 391
 392 /* -----------------------------------------------------------------------------
 393    Nursery management.
 394    -------------------------------------------------------------------------- */
 395
 396 static bdescr *
 397 allocNursery (step *stp, bdescr *tail, nat blocks)
 398 {
 399     bdescr *bd;
 400     nat i;
 401
 402     // Allocate a nursery: we allocate fresh blocks one at a time and
 403     // cons them on to the front of the list, not forgetting to update
 404     // the back pointer on the tail of the list to point to the new block.
 405     for (i=0; i < blocks; i++) {
 406         // @LDV profiling
 407         /*
 408           processNursery() in LdvProfile.c assumes that every block group in
 409           the nursery contains only a single block. So, if a block group is
 410           given multiple blocks, change processNursery() accordingly.
 411         */
 412         bd = allocBlock();
 413         bd->link = tail;
 414         // double-link the nursery: we might need to insert blocks
 415         if (tail != NULL) {
 416             tail->u.back = bd;
 417         }
 418         bd->step = stp;
 419         bd->gen_no = 0;
 420         bd->flags = 0;
 421         bd->free = bd->start;
 422         tail = bd;
 423     }
 424     tail->u.back = NULL;
 425     return tail;
 426 }
 427
 428 static void
 429 assignNurseriesToCapabilities (void)
 430 {
 431 #ifdef THREADED_RTS
 432     nat i;
 433
 434     for (i = 0; i < n_nurseries; i++) {
 435         capabilities[i].r.rNursery        = &nurseries[i];
 436         capabilities[i].r.rCurrentNursery = nurseries[i].blocks;
 437         capabilities[i].r.rCurrentAlloc   = NULL;
 438     }
 439 #else /* THREADED_RTS */
 440     MainCapability.r.rNursery        = &nurseries[0];
 441     MainCapability.r.rCurrentNursery = nurseries[0].blocks;
 442     MainCapability.r.rCurrentAlloc   = NULL;
 443 #endif
 444 }
 445
 446 void
 447 allocNurseries( void )
 448 {
 449     nat i;
 450
 451     for (i = 0; i < n_nurseries; i++) {
 452         nurseries[i].blocks =
 453             allocNursery(&nurseries[i], NULL,
 454                          RtsFlags.GcFlags.minAllocAreaSize);
 455         nurseries[i].n_blocks    = RtsFlags.GcFlags.minAllocAreaSize;
 456         nurseries[i].old_blocks   = NULL;
 457         nurseries[i].n_old_blocks = 0;
 458         /* hp, hpLim, hp_bd, to_space etc. aren't used in the nursery */
 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 += 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 += 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         bd->gen_no = 0;
 768         bd->step   = g0s0;
 769         bd->flags  = BF_PINNED | BF_LARGE;
 770         bd->free   = bd->start;
 771         alloc_blocks++;
 772     }
 773
 774     p = bd->free;
 775     bd->free += n;
 776     RELEASE_SM_LOCK;
 777     return p;
 778 }
 779
 780 /* -----------------------------------------------------------------------------
 781    This is the write barrier for MUT_VARs, a.k.a. IORefs.  A
 782    MUT_VAR_CLEAN object is not on the mutable list; a MUT_VAR_DIRTY
 783    is.  When written to, a MUT_VAR_CLEAN turns into a MUT_VAR_DIRTY
 784    and is put on the mutable list.
 785    -------------------------------------------------------------------------- */
 786
 787 void
 788 dirty_MUT_VAR(StgRegTable *reg, StgClosure *p)
 789 {
 790     Capability *cap = regTableToCapability(reg);
 791     bdescr *bd;
 792     if (p->header.info == &stg_MUT_VAR_CLEAN_info) {
 793         p->header.info = &stg_MUT_VAR_DIRTY_info;
 794         bd = Bdescr((StgPtr)p);
 795         if (bd->gen_no > 0) recordMutableCap(p,cap,bd->gen_no);
 796     }
 797 }
 798
 799 /* -----------------------------------------------------------------------------
 800    Allocation functions for GMP.
 801
 802    These all use the allocate() interface - we can't have any garbage
 803    collection going on during a gmp operation, so we use allocate()
 804    which always succeeds.  The gmp operations which might need to
 805    allocate will ask the storage manager (via doYouWantToGC()) whether
 806    a garbage collection is required, in case we get into a loop doing
 807    only allocate() style allocation.
 808    -------------------------------------------------------------------------- */
 809
 810 static void *
 811 stgAllocForGMP (size_t size_in_bytes)
 812 {
 813   StgArrWords* arr;
 814   nat data_size_in_words, total_size_in_words;
 815
 816   /* round up to a whole number of words */
 817   data_size_in_words  = (size_in_bytes + sizeof(W_) + 1) / sizeof(W_);
 818   total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
 819
 820   /* allocate and fill it in. */
 821 #if defined(THREADED_RTS)
 822   arr = (StgArrWords *)allocateLocal(myTask()->cap, total_size_in_words);
 823 #else
 824   arr = (StgArrWords *)allocateLocal(&MainCapability, total_size_in_words);
 825 #endif
 826   SET_ARR_HDR(arr, &stg_ARR_WORDS_info, CCCS, data_size_in_words);
 827
 828   /* and return a ptr to the goods inside the array */
 829   return arr->payload;
 830 }
 831
 832 static void *
 833 stgReallocForGMP (void *ptr, size_t old_size, size_t new_size)
 834 {
 835     void *new_stuff_ptr = stgAllocForGMP(new_size);
 836     nat i = 0;
 837     char *p = (char *) ptr;
 838     char *q = (char *) new_stuff_ptr;
 839
 840     for (; i < old_size; i++, p++, q++) {
 841         *q = *p;
 842     }
 843
 844     return(new_stuff_ptr);
 845 }
 846
 847 static void
 848 stgDeallocForGMP (void *ptr STG_UNUSED,
 849                   size_t size STG_UNUSED)
 850 {
 851     /* easy for us: the garbage collector does the dealloc'n */
 852 }
 853
 854 /* -----------------------------------------------------------------------------
 855  * Stats and stuff
 856  * -------------------------------------------------------------------------- */
 857
 858 /* -----------------------------------------------------------------------------
 859  * calcAllocated()
 860  *
 861  * Approximate how much we've allocated: number of blocks in the
 862  * nursery + blocks allocated via allocate() - unused nusery blocks.
 863  * This leaves a little slop at the end of each block, and doesn't
 864  * take into account large objects (ToDo).
 865  * -------------------------------------------------------------------------- */
 866
 867 lnat
 868 calcAllocated( void )
 869 {
 870   nat allocated;
 871   bdescr *bd;
 872
 873   allocated = allocatedBytes();
 874   allocated += countNurseryBlocks() * BLOCK_SIZE_W;
 875
 876   {
 877 #ifdef THREADED_RTS
 878   nat i;
 879   for (i = 0; i < n_nurseries; i++) {
 880       Capability *cap;
 881       for ( bd = capabilities[i].r.rCurrentNursery->link;
 882             bd != NULL; bd = bd->link ) {
 883           allocated -= BLOCK_SIZE_W;
 884       }
 885       cap = &capabilities[i];
 886       if (cap->r.rCurrentNursery->free <
 887           cap->r.rCurrentNursery->start + BLOCK_SIZE_W) {
 888           allocated -= (cap->r.rCurrentNursery->start + BLOCK_SIZE_W)
 889               - cap->r.rCurrentNursery->free;
 890       }
 891   }
 892 #else
 893   bdescr *current_nursery = MainCapability.r.rCurrentNursery;
 894
 895   for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
 896       allocated -= BLOCK_SIZE_W;
 897   }
 898   if (current_nursery->free < current_nursery->start + BLOCK_SIZE_W) {
 899       allocated -= (current_nursery->start + BLOCK_SIZE_W)
 900           - current_nursery->free;
 901   }
 902 #endif
 903   }
 904
 905   total_allocated += allocated;
 906   return allocated;
 907 }
 908
 909 /* Approximate the amount of live data in the heap.  To be called just
 910  * after garbage collection (see GarbageCollect()).
 911  */
 912 extern lnat
 913 calcLive(void)
 914 {
 915   nat g, s;
 916   lnat live = 0;
 917   step *stp;
 918
 919   if (RtsFlags.GcFlags.generations == 1) {
 920     live = (g0s0->n_blocks - 1) * BLOCK_SIZE_W +
 921       ((lnat)g0s0->hp_bd->free - (lnat)g0s0->hp_bd->start) / sizeof(W_);
 922     return live;
 923   }
 924
 925   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 926     for (s = 0; s < generations[g].n_steps; s++) {
 927       /* approximate amount of live data (doesn't take into account slop
 928        * at end of each block).
 929        */
 930       if (g == 0 && s == 0) {
 931           continue;
 932       }
 933       stp = &generations[g].steps[s];
 934       live += (stp->n_large_blocks + stp->n_blocks - 1) * BLOCK_SIZE_W;
 935       if (stp->hp_bd != NULL) {
 936           live += ((lnat)stp->hp_bd->free - (lnat)stp->hp_bd->start)
 937               / sizeof(W_);
 938       }
 939       if (stp->scavd_hp != NULL) {
 940           live -= (P_)(BLOCK_ROUND_UP(stp->scavd_hp)) - stp->scavd_hp;
 941       }
 942     }
 943   }
 944   return live;
 945 }
 946
 947 /* Approximate the number of blocks that will be needed at the next
 948  * garbage collection.
 949  *
 950  * Assume: all data currently live will remain live.  Steps that will
 951  * be collected next time will therefore need twice as many blocks
 952  * since all the data will be copied.
 953  */
 954 extern lnat
 955 calcNeeded(void)
 956 {
 957     lnat needed = 0;
 958     nat g, s;
 959     step *stp;
 960
 961     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 962         for (s = 0; s < generations[g].n_steps; s++) {
 963             if (g == 0 && s == 0) { continue; }
 964             stp = &generations[g].steps[s];
 965             if (generations[g].steps[0].n_blocks +
 966                 generations[g].steps[0].n_large_blocks
 967                 > generations[g].max_blocks
 968                 && stp->is_compacted == 0) {
 969                 needed += 2 * stp->n_blocks;
 970             } else {
 971                 needed += stp->n_blocks;
 972             }
 973         }
 974     }
 975     return needed;
 976 }
 977
 978 /* ----------------------------------------------------------------------------
 979    Executable memory
 980
 981    Executable memory must be managed separately from non-executable
 982    memory.  Most OSs these days require you to jump through hoops to
 983    dynamically allocate executable memory, due to various security
 984    measures.
 985
 986    Here we provide a small memory allocator for executable memory.
 987    Memory is managed with a page granularity; we allocate linearly
 988    in the page, and when the page is emptied (all objects on the page
 989    are free) we free the page again, not forgetting to make it
 990    non-executable.
 991    ------------------------------------------------------------------------- */
 992
 993 static bdescr *exec_block;
 994
 995 void *allocateExec (nat bytes)
 996 {
 997     void *ret;
 998     nat n;
 999
1000     ACQUIRE_SM_LOCK;
1001
1002     // round up to words.
1003     n  = (bytes + sizeof(W_) + 1) / sizeof(W_);
1004
1005     if (n+1 > BLOCK_SIZE_W) {
1006         barf("allocateExec: can't handle large objects");
1007     }
1008
1009     if (exec_block == NULL ||
1010         exec_block->free + n + 1 > exec_block->start + BLOCK_SIZE_W) {
1011         bdescr *bd;
1012         lnat pagesize = getPageSize();
1013         bd = allocGroup(stg_max(1, pagesize / BLOCK_SIZE));
1014         debugTrace(DEBUG_gc, "allocate exec block %p", bd->start);
1015         bd->gen_no = 0;
1016         bd->flags = BF_EXEC;
1017         bd->link = exec_block;
1018         if (exec_block != NULL) {
1019             exec_block->u.back = bd;
1020         }
1021         bd->u.back = NULL;
1022         setExecutable(bd->start, bd->blocks * BLOCK_SIZE, rtsTrue);
1023         exec_block = bd;
1024     }
1025     *(exec_block->free) = n;  // store the size of this chunk
1026     exec_block->gen_no += n;  // gen_no stores the number of words allocated
1027     ret = exec_block->free + 1;
1028     exec_block->free += n + 1;
1029
1030     RELEASE_SM_LOCK
1031     return ret;
1032 }
1033
1034 void freeExec (void *addr)
1035 {
1036     StgPtr p = (StgPtr)addr - 1;
1037     bdescr *bd = Bdescr((StgPtr)p);
1038
1039     if ((bd->flags & BF_EXEC) == 0) {
1040         barf("freeExec: not executable");
1041     }
1042
1043     if (*(StgPtr)p == 0) {
1044         barf("freeExec: already free?");
1045     }
1046
1047     ACQUIRE_SM_LOCK;
1048
1049     bd->gen_no -= *(StgPtr)p;
1050     *(StgPtr)p = 0;
1051
1052     // Free the block if it is empty, but not if it is the block at
1053     // the head of the queue.
1054     if (bd->gen_no == 0 && bd != exec_block) {
1055         debugTrace(DEBUG_gc, "free exec block %p", bd->start);
1056         if (bd->u.back) {
1057             bd->u.back->link = bd->link;
1058         } else {
1059             exec_block = bd->link;
1060         }
1061         if (bd->link) {
1062             bd->link->u.back = bd->u.back;
1063         }
1064         setExecutable(bd->start, bd->blocks * BLOCK_SIZE, rtsFalse);
1065         freeGroup(bd);
1066     }
1067
1068     RELEASE_SM_LOCK
1069 }
1070
1071 /* -----------------------------------------------------------------------------
1072    Debugging
1073
1074    memInventory() checks for memory leaks by counting up all the
1075    blocks we know about and comparing that to the number of blocks
1076    allegedly floating around in the system.
1077    -------------------------------------------------------------------------- */
1078
1079 #ifdef DEBUG
1080
1081 static lnat
1082 stepBlocks (step *stp)
1083 {
1084     lnat total_blocks;
1085     bdescr *bd;
1086
1087     total_blocks = stp->n_blocks;
1088     total_blocks += stp->n_old_blocks;
1089     for (bd = stp->large_objects; bd; bd = bd->link) {
1090         total_blocks += bd->blocks;
1091         /* hack for megablock groups: they have an extra block or two in
1092            the second and subsequent megablocks where the block
1093            descriptors would normally go.
1094         */
1095         if (bd->blocks > BLOCKS_PER_MBLOCK) {
1096             total_blocks -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
1097                 * (bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE));
1098         }
1099     }
1100     return total_blocks;
1101 }
1102
1103 void
1104 memInventory(void)
1105 {
1106   nat g, s, i;
1107   step *stp;
1108   bdescr *bd;
1109   lnat total_blocks = 0, free_blocks = 0;
1110
1111   /* count the blocks we current have */
1112
1113   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1114       for (i = 0; i < n_capabilities; i++) {
1115           for (bd = capabilities[i].mut_lists[g]; bd != NULL; bd = bd->link) {
1116               total_blocks += bd->blocks;
1117           }
1118       }
1119       for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
1120           total_blocks += bd->blocks;
1121       }
1122       for (s = 0; s < generations[g].n_steps; s++) {
1123           if (g==0 && s==0) continue;
1124           stp = &generations[g].steps[s];
1125           total_blocks += stepBlocks(stp);
1126       }
1127   }
1128
1129   for (i = 0; i < n_nurseries; i++) {
1130       total_blocks += stepBlocks(&nurseries[i]);
1131   }
1132 #ifdef THREADED_RTS
1133   // We put pinned object blocks in g0s0, so better count blocks there too.
1134   total_blocks += stepBlocks(g0s0);
1135 #endif
1136
1137   /* any blocks held by allocate() */
1138   for (bd = small_alloc_list; bd; bd = bd->link) {
1139     total_blocks += bd->blocks;
1140   }
1141
1142 #ifdef PROFILING
1143   if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_RETAINER) {
1144       total_blocks += retainerStackBlocks();
1145   }
1146 #endif
1147
1148   // count the blocks allocated by the arena allocator
1149   total_blocks += arenaBlocks();
1150
1151   // count the blocks containing executable memory
1152   for (bd = exec_block; bd; bd = bd->link) {
1153     total_blocks += bd->blocks;
1154   }
1155
1156   /* count the blocks on the free list */
1157   free_blocks = countFreeList();
1158
1159   if (total_blocks + free_blocks != mblocks_allocated *
1160       BLOCKS_PER_MBLOCK) {
1161     debugBelch("Blocks: %ld live + %ld free  = %ld total (%ld around)\n",
1162             total_blocks, free_blocks, total_blocks + free_blocks,
1163             mblocks_allocated * BLOCKS_PER_MBLOCK);
1164   }
1165
1166   ASSERT(total_blocks + free_blocks == mblocks_allocated * BLOCKS_PER_MBLOCK);
1167 }
1168
1169
1170 nat
1171 countBlocks(bdescr *bd)
1172 {
1173     nat n;
1174     for (n=0; bd != NULL; bd=bd->link) {
1175         n += bd->blocks;
1176     }
1177     return n;
1178 }
1179
1180 /* Full heap sanity check. */
1181 void
1182 checkSanity( void )
1183 {
1184     nat g, s;
1185
1186     if (RtsFlags.GcFlags.generations == 1) {
1187         checkHeap(g0s0->blocks);
1188         checkChain(g0s0->large_objects);
1189     } else {
1190
1191         for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1192             for (s = 0; s < generations[g].n_steps; s++) {
1193                 if (g == 0 && s == 0) { continue; }
1194                 ASSERT(countBlocks(generations[g].steps[s].blocks)
1195                        == generations[g].steps[s].n_blocks);
1196                 ASSERT(countBlocks(generations[g].steps[s].large_objects)
1197                        == generations[g].steps[s].n_large_blocks);
1198                 checkHeap(generations[g].steps[s].blocks);
1199                 checkChain(generations[g].steps[s].large_objects);
1200                 if (g > 0) {
1201                     checkMutableList(generations[g].mut_list, g);
1202                 }
1203             }
1204         }
1205
1206         for (s = 0; s < n_nurseries; s++) {
1207             ASSERT(countBlocks(nurseries[s].blocks)
1208                    == nurseries[s].n_blocks);
1209             ASSERT(countBlocks(nurseries[s].large_objects)
1210                    == nurseries[s].n_large_blocks);
1211         }
1212
1213         checkFreeListSanity();
1214     }
1215 }
1216
1217 /* Nursery sanity check */
1218 void
1219 checkNurserySanity( step *stp )
1220 {
1221     bdescr *bd, *prev;
1222     nat blocks = 0;
1223
1224     prev = NULL;
1225     for (bd = stp->blocks; bd != NULL; bd = bd->link) {
1226         ASSERT(bd->u.back == prev);
1227         prev = bd;
1228         blocks += bd->blocks;
1229     }
1230     ASSERT(blocks == stp->n_blocks);
1231 }
1232
1233 // handy function for use in gdb, because Bdescr() is inlined.
1234 extern bdescr *_bdescr( StgPtr p );
1235
1236 bdescr *
1237 _bdescr( StgPtr p )
1238 {
1239     return Bdescr(p);
1240 }
1241
1242 #endif