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     }
 459     assignNurseriesToCapabilities();
 460 }
 461
 462 void
 463 resetNurseries( void )
 464 {
 465     nat i;
 466     bdescr *bd;
 467     step *stp;
 468
 469     for (i = 0; i < n_nurseries; i++) {
 470         stp = &nurseries[i];
 471         for (bd = stp->blocks; bd; bd = bd->link) {
 472             bd->free = bd->start;
 473             ASSERT(bd->gen_no == 0);
 474             ASSERT(bd->step == stp);
 475             IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
 476         }
 477     }
 478     assignNurseriesToCapabilities();
 479 }
 480
 481 lnat
 482 countNurseryBlocks (void)
 483 {
 484     nat i;
 485     lnat blocks = 0;
 486
 487     for (i = 0; i < n_nurseries; i++) {
 488         blocks += nurseries[i].n_blocks;
 489     }
 490     return blocks;
 491 }
 492
 493 static void
 494 resizeNursery ( step *stp, nat blocks )
 495 {
 496   bdescr *bd;
 497   nat nursery_blocks;
 498
 499   nursery_blocks = stp->n_blocks;
 500   if (nursery_blocks == blocks) return;
 501
 502   if (nursery_blocks < blocks) {
 503       debugTrace(DEBUG_gc, "increasing size of nursery to %d blocks",
 504                  blocks);
 505     stp->blocks = allocNursery(stp, stp->blocks, blocks-nursery_blocks);
 506   }
 507   else {
 508     bdescr *next_bd;
 509
 510     debugTrace(DEBUG_gc, "decreasing size of nursery to %d blocks",
 511                blocks);
 512
 513     bd = stp->blocks;
 514     while (nursery_blocks > blocks) {
 515         next_bd = bd->link;
 516         next_bd->u.back = NULL;
 517         nursery_blocks -= bd->blocks; // might be a large block
 518         freeGroup(bd);
 519         bd = next_bd;
 520     }
 521     stp->blocks = bd;
 522     // might have gone just under, by freeing a large block, so make
 523     // up the difference.
 524     if (nursery_blocks < blocks) {
 525         stp->blocks = allocNursery(stp, stp->blocks, blocks-nursery_blocks);
 526     }
 527   }
 528
 529   stp->n_blocks = blocks;
 530   ASSERT(countBlocks(stp->blocks) == stp->n_blocks);
 531 }
 532
 533 //
 534 // Resize each of the nurseries to the specified size.
 535 //
 536 void
 537 resizeNurseriesFixed (nat blocks)
 538 {
 539     nat i;
 540     for (i = 0; i < n_nurseries; i++) {
 541         resizeNursery(&nurseries[i], blocks);
 542     }
 543 }
 544
 545 //
 546 // Resize the nurseries to the total specified size.
 547 //
 548 void
 549 resizeNurseries (nat blocks)
 550 {
 551     // If there are multiple nurseries, then we just divide the number
 552     // of available blocks between them.
 553     resizeNurseriesFixed(blocks / n_nurseries);
 554 }
 555
 556 /* -----------------------------------------------------------------------------
 557    The allocate() interface
 558
 559    allocate(n) always succeeds, and returns a chunk of memory n words
 560    long.  n can be larger than the size of a block if necessary, in
 561    which case a contiguous block group will be allocated.
 562    -------------------------------------------------------------------------- */
 563
 564 StgPtr
 565 allocate( nat n )
 566 {
 567     bdescr *bd;
 568     StgPtr p;
 569
 570     ACQUIRE_SM_LOCK;
 571
 572     TICK_ALLOC_HEAP_NOCTR(n);
 573     CCS_ALLOC(CCCS,n);
 574
 575     /* big allocation (>LARGE_OBJECT_THRESHOLD) */
 576     /* ToDo: allocate directly into generation 1 */
 577     if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
 578         nat req_blocks =  (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
 579         bd = allocGroup(req_blocks);
 580         dbl_link_onto(bd, &g0s0->large_objects);
 581         g0s0->n_large_blocks += req_blocks;
 582         bd->gen_no  = 0;
 583         bd->step = g0s0;
 584         bd->flags = BF_LARGE;
 585         bd->free = bd->start + n;
 586         alloc_blocks += req_blocks;
 587         RELEASE_SM_LOCK;
 588         return bd->start;
 589
 590         /* small allocation (<LARGE_OBJECT_THRESHOLD) */
 591     } else if (small_alloc_list == NULL || alloc_Hp + n > alloc_HpLim) {
 592         if (small_alloc_list) {
 593             small_alloc_list->free = alloc_Hp;
 594         }
 595         bd = allocBlock();
 596         bd->link = small_alloc_list;
 597         small_alloc_list = bd;
 598         bd->gen_no = 0;
 599         bd->step = g0s0;
 600         bd->flags = 0;
 601         alloc_Hp = bd->start;
 602         alloc_HpLim = bd->start + BLOCK_SIZE_W;
 603         alloc_blocks++;
 604     }
 605
 606     p = alloc_Hp;
 607     alloc_Hp += n;
 608     RELEASE_SM_LOCK;
 609     return p;
 610 }
 611
 612 lnat
 613 allocatedBytes( void )
 614 {
 615     lnat allocated;
 616
 617     allocated = alloc_blocks * BLOCK_SIZE_W - (alloc_HpLim - alloc_Hp);
 618     if (pinned_object_block != NULL) {
 619         allocated -= (pinned_object_block->start + BLOCK_SIZE_W) -
 620             pinned_object_block->free;
 621     }
 622
 623     return allocated;
 624 }
 625
 626 void
 627 tidyAllocateLists (void)
 628 {
 629     if (small_alloc_list != NULL) {
 630         ASSERT(alloc_Hp >= small_alloc_list->start &&
 631                alloc_Hp <= small_alloc_list->start + BLOCK_SIZE);
 632         small_alloc_list->free = alloc_Hp;
 633     }
 634 }
 635
 636 /* -----------------------------------------------------------------------------
 637    allocateLocal()
 638
 639    This allocates memory in the current thread - it is intended for
 640    use primarily from STG-land where we have a Capability.  It is
 641    better than allocate() because it doesn't require taking the
 642    sm_mutex lock in the common case.
 643
 644    Memory is allocated directly from the nursery if possible (but not
 645    from the current nursery block, so as not to interfere with
 646    Hp/HpLim).
 647    -------------------------------------------------------------------------- */
 648
 649 StgPtr
 650 allocateLocal (Capability *cap, nat n)
 651 {
 652     bdescr *bd;
 653     StgPtr p;
 654
 655     TICK_ALLOC_HEAP_NOCTR(n);
 656     CCS_ALLOC(CCCS,n);
 657
 658     /* big allocation (>LARGE_OBJECT_THRESHOLD) */
 659     /* ToDo: allocate directly into generation 1 */
 660     if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
 661         nat req_blocks =  (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
 662         ACQUIRE_SM_LOCK;
 663         bd = allocGroup(req_blocks);
 664         dbl_link_onto(bd, &g0s0->large_objects);
 665         g0s0->n_large_blocks += req_blocks;
 666         bd->gen_no  = 0;
 667         bd->step = g0s0;
 668         bd->flags = BF_LARGE;
 669         bd->free = bd->start + n;
 670         alloc_blocks += req_blocks;
 671         RELEASE_SM_LOCK;
 672         return bd->start;
 673
 674         /* small allocation (<LARGE_OBJECT_THRESHOLD) */
 675     } else {
 676
 677         bd = cap->r.rCurrentAlloc;
 678         if (bd == NULL || bd->free + n > bd->start + BLOCK_SIZE_W) {
 679
 680             // The CurrentAlloc block is full, we need to find another
 681             // one.  First, we try taking the next block from the
 682             // nursery:
 683             bd = cap->r.rCurrentNursery->link;
 684
 685             if (bd == NULL || bd->free + n > bd->start + BLOCK_SIZE_W) {
 686                 // The nursery is empty, or the next block is already
 687                 // full: allocate a fresh block (we can't fail here).
 688                 ACQUIRE_SM_LOCK;
 689                 bd = allocBlock();
 690                 cap->r.rNursery->n_blocks++;
 691                 RELEASE_SM_LOCK;
 692                 bd->gen_no = 0;
 693                 bd->step = cap->r.rNursery;
 694                 bd->flags = 0;
 695             } else {
 696                 // we have a block in the nursery: take it and put
 697                 // it at the *front* of the nursery list, and use it
 698                 // to allocate() from.
 699                 cap->r.rCurrentNursery->link = bd->link;
 700                 if (bd->link != NULL) {
 701                     bd->link->u.back = cap->r.rCurrentNursery;
 702                 }
 703             }
 704             dbl_link_onto(bd, &cap->r.rNursery->blocks);
 705             cap->r.rCurrentAlloc = bd;
 706             IF_DEBUG(sanity, checkNurserySanity(cap->r.rNursery));
 707         }
 708     }
 709     p = bd->free;
 710     bd->free += n;
 711     return p;
 712 }
 713
 714 /* ---------------------------------------------------------------------------
 715    Allocate a fixed/pinned object.
 716
 717    We allocate small pinned objects into a single block, allocating a
 718    new block when the current one overflows.  The block is chained
 719    onto the large_object_list of generation 0 step 0.
 720
 721    NOTE: The GC can't in general handle pinned objects.  This
 722    interface is only safe to use for ByteArrays, which have no
 723    pointers and don't require scavenging.  It works because the
 724    block's descriptor has the BF_LARGE flag set, so the block is
 725    treated as a large object and chained onto various lists, rather
 726    than the individual objects being copied.  However, when it comes
 727    to scavenge the block, the GC will only scavenge the first object.
 728    The reason is that the GC can't linearly scan a block of pinned
 729    objects at the moment (doing so would require using the
 730    mostly-copying techniques).  But since we're restricting ourselves
 731    to pinned ByteArrays, not scavenging is ok.
 732
 733    This function is called by newPinnedByteArray# which immediately
 734    fills the allocated memory with a MutableByteArray#.
 735    ------------------------------------------------------------------------- */
 736
 737 StgPtr
 738 allocatePinned( nat n )
 739 {
 740     StgPtr p;
 741     bdescr *bd = pinned_object_block;
 742
 743     // If the request is for a large object, then allocate()
 744     // will give us a pinned object anyway.
 745     if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
 746         return allocate(n);
 747     }
 748
 749     ACQUIRE_SM_LOCK;
 750
 751     TICK_ALLOC_HEAP_NOCTR(n);
 752     CCS_ALLOC(CCCS,n);
 753
 754     // we always return 8-byte aligned memory.  bd->free must be
 755     // 8-byte aligned to begin with, so we just round up n to
 756     // the nearest multiple of 8 bytes.
 757     if (sizeof(StgWord) == 4) {
 758         n = (n+1) & ~1;
 759     }
 760
 761     // If we don't have a block of pinned objects yet, or the current
 762     // one isn't large enough to hold the new object, allocate a new one.
 763     if (bd == NULL || (bd->free + n) > (bd->start + BLOCK_SIZE_W)) {
 764         pinned_object_block = bd = allocBlock();
 765         dbl_link_onto(bd, &g0s0->large_objects);
 766         bd->gen_no = 0;
 767         bd->step   = g0s0;
 768         bd->flags  = BF_PINNED | BF_LARGE;
 769         bd->free   = bd->start;
 770         alloc_blocks++;
 771     }
 772
 773     p = bd->free;
 774     bd->free += n;
 775     RELEASE_SM_LOCK;
 776     return p;
 777 }
 778
 779 /* -----------------------------------------------------------------------------
 780    This is the write barrier for MUT_VARs, a.k.a. IORefs.  A
 781    MUT_VAR_CLEAN object is not on the mutable list; a MUT_VAR_DIRTY
 782    is.  When written to, a MUT_VAR_CLEAN turns into a MUT_VAR_DIRTY
 783    and is put on the mutable list.
 784    -------------------------------------------------------------------------- */
 785
 786 void
 787 dirty_MUT_VAR(StgRegTable *reg, StgClosure *p)
 788 {
 789     Capability *cap = regTableToCapability(reg);
 790     bdescr *bd;
 791     if (p->header.info == &stg_MUT_VAR_CLEAN_info) {
 792         p->header.info = &stg_MUT_VAR_DIRTY_info;
 793         bd = Bdescr((StgPtr)p);
 794         if (bd->gen_no > 0) recordMutableCap(p,cap,bd->gen_no);
 795     }
 796 }
 797
 798 /* -----------------------------------------------------------------------------
 799    Allocation functions for GMP.
 800
 801    These all use the allocate() interface - we can't have any garbage
 802    collection going on during a gmp operation, so we use allocate()
 803    which always succeeds.  The gmp operations which might need to
 804    allocate will ask the storage manager (via doYouWantToGC()) whether
 805    a garbage collection is required, in case we get into a loop doing
 806    only allocate() style allocation.
 807    -------------------------------------------------------------------------- */
 808
 809 static void *
 810 stgAllocForGMP (size_t size_in_bytes)
 811 {
 812   StgArrWords* arr;
 813   nat data_size_in_words, total_size_in_words;
 814
 815   /* round up to a whole number of words */
 816   data_size_in_words  = (size_in_bytes + sizeof(W_) + 1) / sizeof(W_);
 817   total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
 818
 819   /* allocate and fill it in. */
 820 #if defined(THREADED_RTS)
 821   arr = (StgArrWords *)allocateLocal(myTask()->cap, total_size_in_words);
 822 #else
 823   arr = (StgArrWords *)allocateLocal(&MainCapability, total_size_in_words);
 824 #endif
 825   SET_ARR_HDR(arr, &stg_ARR_WORDS_info, CCCS, data_size_in_words);
 826
 827   /* and return a ptr to the goods inside the array */
 828   return arr->payload;
 829 }
 830
 831 static void *
 832 stgReallocForGMP (void *ptr, size_t old_size, size_t new_size)
 833 {
 834     void *new_stuff_ptr = stgAllocForGMP(new_size);
 835     nat i = 0;
 836     char *p = (char *) ptr;
 837     char *q = (char *) new_stuff_ptr;
 838
 839     for (; i < old_size; i++, p++, q++) {
 840         *q = *p;
 841     }
 842
 843     return(new_stuff_ptr);
 844 }
 845
 846 static void
 847 stgDeallocForGMP (void *ptr STG_UNUSED,
 848                   size_t size STG_UNUSED)
 849 {
 850     /* easy for us: the garbage collector does the dealloc'n */
 851 }
 852
 853 /* -----------------------------------------------------------------------------
 854  * Stats and stuff
 855  * -------------------------------------------------------------------------- */
 856
 857 /* -----------------------------------------------------------------------------
 858  * calcAllocated()
 859  *
 860  * Approximate how much we've allocated: number of blocks in the
 861  * nursery + blocks allocated via allocate() - unused nusery blocks.
 862  * This leaves a little slop at the end of each block, and doesn't
 863  * take into account large objects (ToDo).
 864  * -------------------------------------------------------------------------- */
 865
 866 lnat
 867 calcAllocated( void )
 868 {
 869   nat allocated;
 870   bdescr *bd;
 871
 872   allocated = allocatedBytes();
 873   allocated += countNurseryBlocks() * BLOCK_SIZE_W;
 874
 875   {
 876 #ifdef THREADED_RTS
 877   nat i;
 878   for (i = 0; i < n_nurseries; i++) {
 879       Capability *cap;
 880       for ( bd = capabilities[i].r.rCurrentNursery->link;
 881             bd != NULL; bd = bd->link ) {
 882           allocated -= BLOCK_SIZE_W;
 883       }
 884       cap = &capabilities[i];
 885       if (cap->r.rCurrentNursery->free <
 886           cap->r.rCurrentNursery->start + BLOCK_SIZE_W) {
 887           allocated -= (cap->r.rCurrentNursery->start + BLOCK_SIZE_W)
 888               - cap->r.rCurrentNursery->free;
 889       }
 890   }
 891 #else
 892   bdescr *current_nursery = MainCapability.r.rCurrentNursery;
 893
 894   for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
 895       allocated -= BLOCK_SIZE_W;
 896   }
 897   if (current_nursery->free < current_nursery->start + BLOCK_SIZE_W) {
 898       allocated -= (current_nursery->start + BLOCK_SIZE_W)
 899           - current_nursery->free;
 900   }
 901 #endif
 902   }
 903
 904   total_allocated += allocated;
 905   return allocated;
 906 }
 907
 908 /* Approximate the amount of live data in the heap.  To be called just
 909  * after garbage collection (see GarbageCollect()).
 910  */
 911 extern lnat
 912 calcLive(void)
 913 {
 914   nat g, s;
 915   lnat live = 0;
 916   step *stp;
 917
 918   if (RtsFlags.GcFlags.generations == 1) {
 919       return (g0s0->n_large_blocks + g0s0->n_blocks) * BLOCK_SIZE_W;
 920   }
 921
 922   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 923     for (s = 0; s < generations[g].n_steps; s++) {
 924       /* approximate amount of live data (doesn't take into account slop
 925        * at end of each block).
 926        */
 927       if (g == 0 && s == 0) {
 928           continue;
 929       }
 930       stp = &generations[g].steps[s];
 931       live += (stp->n_large_blocks + stp->n_blocks) * BLOCK_SIZE_W;
 932     }
 933   }
 934   return live;
 935 }
 936
 937 /* Approximate the number of blocks that will be needed at the next
 938  * garbage collection.
 939  *
 940  * Assume: all data currently live will remain live.  Steps that will
 941  * be collected next time will therefore need twice as many blocks
 942  * since all the data will be copied.
 943  */
 944 extern lnat
 945 calcNeeded(void)
 946 {
 947     lnat needed = 0;
 948     nat g, s;
 949     step *stp;
 950
 951     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 952         for (s = 0; s < generations[g].n_steps; s++) {
 953             if (g == 0 && s == 0) { continue; }
 954             stp = &generations[g].steps[s];
 955             if (generations[g].steps[0].n_blocks +
 956                 generations[g].steps[0].n_large_blocks
 957                 > generations[g].max_blocks
 958                 && stp->is_compacted == 0) {
 959                 needed += 2 * stp->n_blocks;
 960             } else {
 961                 needed += stp->n_blocks;
 962             }
 963         }
 964     }
 965     return needed;
 966 }
 967
 968 /* ----------------------------------------------------------------------------
 969    Executable memory
 970
 971    Executable memory must be managed separately from non-executable
 972    memory.  Most OSs these days require you to jump through hoops to
 973    dynamically allocate executable memory, due to various security
 974    measures.
 975
 976    Here we provide a small memory allocator for executable memory.
 977    Memory is managed with a page granularity; we allocate linearly
 978    in the page, and when the page is emptied (all objects on the page
 979    are free) we free the page again, not forgetting to make it
 980    non-executable.
 981    ------------------------------------------------------------------------- */
 982
 983 static bdescr *exec_block;
 984
 985 void *allocateExec (nat bytes)
 986 {
 987     void *ret;
 988     nat n;
 989
 990     ACQUIRE_SM_LOCK;
 991
 992     // round up to words.
 993     n  = (bytes + sizeof(W_) + 1) / sizeof(W_);
 994
 995     if (n+1 > BLOCK_SIZE_W) {
 996         barf("allocateExec: can't handle large objects");
 997     }
 998
 999     if (exec_block == NULL ||
1000         exec_block->free + n + 1 > exec_block->start + BLOCK_SIZE_W) {
1001         bdescr *bd;
1002         lnat pagesize = getPageSize();
1003         bd = allocGroup(stg_max(1, pagesize / BLOCK_SIZE));
1004         debugTrace(DEBUG_gc, "allocate exec block %p", bd->start);
1005         bd->gen_no = 0;
1006         bd->flags = BF_EXEC;
1007         bd->link = exec_block;
1008         if (exec_block != NULL) {
1009             exec_block->u.back = bd;
1010         }
1011         bd->u.back = NULL;
1012         setExecutable(bd->start, bd->blocks * BLOCK_SIZE, rtsTrue);
1013         exec_block = bd;
1014     }
1015     *(exec_block->free) = n;  // store the size of this chunk
1016     exec_block->gen_no += n;  // gen_no stores the number of words allocated
1017     ret = exec_block->free + 1;
1018     exec_block->free += n + 1;
1019
1020     RELEASE_SM_LOCK
1021     return ret;
1022 }
1023
1024 void freeExec (void *addr)
1025 {
1026     StgPtr p = (StgPtr)addr - 1;
1027     bdescr *bd = Bdescr((StgPtr)p);
1028
1029     if ((bd->flags & BF_EXEC) == 0) {
1030         barf("freeExec: not executable");
1031     }
1032
1033     if (*(StgPtr)p == 0) {
1034         barf("freeExec: already free?");
1035     }
1036
1037     ACQUIRE_SM_LOCK;
1038
1039     bd->gen_no -= *(StgPtr)p;
1040     *(StgPtr)p = 0;
1041
1042     // Free the block if it is empty, but not if it is the block at
1043     // the head of the queue.
1044     if (bd->gen_no == 0 && bd != exec_block) {
1045         debugTrace(DEBUG_gc, "free exec block %p", bd->start);
1046         if (bd->u.back) {
1047             bd->u.back->link = bd->link;
1048         } else {
1049             exec_block = bd->link;
1050         }
1051         if (bd->link) {
1052             bd->link->u.back = bd->u.back;
1053         }
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 static lnat
1072 stepBlocks (step *stp)
1073 {
1074     lnat total_blocks;
1075     bdescr *bd;
1076
1077     total_blocks = stp->n_blocks;
1078     total_blocks += stp->n_old_blocks;
1079     for (bd = stp->large_objects; bd; bd = bd->link) {
1080         total_blocks += bd->blocks;
1081         /* hack for megablock groups: they have an extra block or two in
1082            the second and subsequent megablocks where the block
1083            descriptors would normally go.
1084         */
1085         if (bd->blocks > BLOCKS_PER_MBLOCK) {
1086             total_blocks -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
1087                 * (bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE));
1088         }
1089     }
1090     return total_blocks;
1091 }
1092
1093 void
1094 memInventory(void)
1095 {
1096   nat g, s, i;
1097   step *stp;
1098   bdescr *bd;
1099   lnat gen_blocks[RtsFlags.GcFlags.generations];
1100   lnat nursery_blocks, allocate_blocks, retainer_blocks,
1101        arena_blocks, exec_blocks;
1102   lnat live_blocks = 0, free_blocks = 0;
1103
1104   // count the blocks we current have
1105
1106   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1107       gen_blocks[g] = 0;
1108       for (i = 0; i < n_capabilities; i++) {
1109           for (bd = capabilities[i].mut_lists[g]; bd != NULL; bd = bd->link) {
1110               gen_blocks[g] += bd->blocks;
1111           }
1112       }
1113       for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
1114           gen_blocks[g] += bd->blocks;
1115       }
1116       for (s = 0; s < generations[g].n_steps; s++) {
1117           if (g==0 && s==0) continue;
1118           stp = &generations[g].steps[s];
1119           gen_blocks[g] += stepBlocks(stp);
1120       }
1121   }
1122
1123   nursery_blocks = 0;
1124   for (i = 0; i < n_nurseries; i++) {
1125       nursery_blocks += stepBlocks(&nurseries[i]);
1126   }
1127 #ifdef THREADED_RTS
1128   // We put pinned object blocks in g0s0, so better count blocks there too.
1129   gen_blocks[0] += stepBlocks(g0s0);
1130 #endif
1131
1132   /* any blocks held by allocate() */
1133   allocate_blocks = 0;
1134   for (bd = small_alloc_list; bd; bd = bd->link) {
1135       allocate_blocks += bd->blocks;
1136   }
1137
1138   retainer_blocks = 0;
1139 #ifdef PROFILING
1140   if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_RETAINER) {
1141       retainer_blocks = retainerStackBlocks();
1142   }
1143 #endif
1144
1145   // count the blocks allocated by the arena allocator
1146   arena_blocks = arenaBlocks();
1147
1148   // count the blocks containing executable memory
1149   exec_blocks = 0;
1150   for (bd = exec_block; bd; bd = bd->link) {
1151       exec_blocks += bd->blocks;
1152   }
1153
1154   /* count the blocks on the free list */
1155   free_blocks = countFreeList();
1156
1157   live_blocks = 0;
1158   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1159       live_blocks += gen_blocks[g];
1160   }
1161   live_blocks += nursery_blocks + allocate_blocks
1162                + retainer_blocks + arena_blocks + exec_blocks;
1163
1164   if (live_blocks + free_blocks != mblocks_allocated * BLOCKS_PER_MBLOCK)
1165   {
1166       debugBelch("Memory leak detected\n");
1167       for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1168           debugBelch("  gen %d blocks : %4lu\n", g, gen_blocks[g]);
1169       }
1170       debugBelch("  nursery      : %4lu\n", nursery_blocks);
1171       debugBelch("  allocate()   : %4lu\n", allocate_blocks);
1172       debugBelch("  retainer     : %4lu\n", retainer_blocks);
1173       debugBelch("  arena blocks : %4lu\n", arena_blocks);
1174       debugBelch("  exec         : %4lu\n", exec_blocks);
1175       debugBelch("  free         : %4lu\n", free_blocks);
1176       debugBelch("  total        : %4lu\n\n", live_blocks + free_blocks);
1177       debugBelch("  in system    : %4lu\n", mblocks_allocated + BLOCKS_PER_MBLOCK);
1178       ASSERT(0);
1179   }
1180 }
1181
1182
1183 nat
1184 countBlocks(bdescr *bd)
1185 {
1186     nat n;
1187     for (n=0; bd != NULL; bd=bd->link) {
1188         n += bd->blocks;
1189     }
1190     return n;
1191 }
1192
1193 /* Full heap sanity check. */
1194 void
1195 checkSanity( void )
1196 {
1197     nat g, s;
1198
1199     if (RtsFlags.GcFlags.generations == 1) {
1200         checkHeap(g0s0->blocks);
1201         checkChain(g0s0->large_objects);
1202     } else {
1203
1204         for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1205             for (s = 0; s < generations[g].n_steps; s++) {
1206                 if (g == 0 && s == 0) { continue; }
1207                 ASSERT(countBlocks(generations[g].steps[s].blocks)
1208                        == generations[g].steps[s].n_blocks);
1209                 ASSERT(countBlocks(generations[g].steps[s].large_objects)
1210                        == generations[g].steps[s].n_large_blocks);
1211                 checkHeap(generations[g].steps[s].blocks);
1212                 checkChain(generations[g].steps[s].large_objects);
1213                 if (g > 0) {
1214                     checkMutableList(generations[g].mut_list, g);
1215                 }
1216             }
1217         }
1218
1219         for (s = 0; s < n_nurseries; s++) {
1220             ASSERT(countBlocks(nurseries[s].blocks)
1221                    == nurseries[s].n_blocks);
1222             ASSERT(countBlocks(nurseries[s].large_objects)
1223                    == nurseries[s].n_large_blocks);
1224         }
1225
1226         checkFreeListSanity();
1227     }
1228 }
1229
1230 /* Nursery sanity check */
1231 void
1232 checkNurserySanity( step *stp )
1233 {
1234     bdescr *bd, *prev;
1235     nat blocks = 0;
1236
1237     prev = NULL;
1238     for (bd = stp->blocks; bd != NULL; bd = bd->link) {
1239         ASSERT(bd->u.back == prev);
1240         prev = bd;
1241         blocks += bd->blocks;
1242     }
1243     ASSERT(blocks == stp->n_blocks);
1244 }
1245
1246 // handy function for use in gdb, because Bdescr() is inlined.
1247 extern bdescr *_bdescr( StgPtr p );
1248
1249 bdescr *
1250 _bdescr( StgPtr p )
1251 {
1252     return Bdescr(p);
1253 }
1254
1255 #endif