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 *pinned_object_block;    /* allocate pinned objects into this block */
  44 nat alloc_blocks;               /* number of allocate()d blocks since GC */
  45 nat alloc_blocks_lim;           /* approximate limit on alloc_blocks */
  46
  47 generation *generations = NULL; /* all the generations */
  48 generation *g0          = NULL; /* generation 0, for convenience */
  49 generation *oldest_gen  = NULL; /* oldest generation, for convenience */
  50 step *g0s0              = NULL; /* generation 0, step 0, for convenience */
  51
  52 ullong total_allocated = 0;     /* total memory allocated during run */
  53
  54 nat n_nurseries         = 0;    /* == RtsFlags.ParFlags.nNodes, convenience */
  55 step *nurseries         = NULL; /* array of nurseries, >1 only if THREADED_RTS */
  56
  57 #ifdef THREADED_RTS
  58 /*
  59  * Storage manager mutex:  protects all the above state from
  60  * simultaneous access by two STG threads.
  61  */
  62 Mutex sm_mutex;
  63 /*
  64  * This mutex is used by atomicModifyMutVar# only
  65  */
  66 Mutex atomic_modify_mutvar_mutex;
  67 #endif
  68
  69
  70 /*
  71  * Forward references
  72  */
  73 static void *stgAllocForGMP   (size_t size_in_bytes);
  74 static void *stgReallocForGMP (void *ptr, size_t old_size, size_t new_size);
  75 static void  stgDeallocForGMP (void *ptr, size_t size);
  76
  77 static void
  78 initStep (step *stp, int g, int s)
  79 {
  80     stp->no = s;
  81     stp->blocks = NULL;
  82     stp->n_blocks = 0;
  83     stp->old_blocks = NULL;
  84     stp->n_old_blocks = 0;
  85     stp->gen = &generations[g];
  86     stp->gen_no = g;
  87     stp->hp = NULL;
  88     stp->hpLim = NULL;
  89     stp->hp_bd = NULL;
  90     stp->scavd_hp = NULL;
  91     stp->scavd_hpLim = NULL;
  92     stp->scan = NULL;
  93     stp->scan_bd = NULL;
  94     stp->large_objects = NULL;
  95     stp->n_large_blocks = 0;
  96     stp->new_large_objects = NULL;
  97     stp->scavenged_large_objects = NULL;
  98     stp->n_scavenged_large_blocks = 0;
  99     stp->is_compacted = 0;
 100     stp->bitmap = NULL;
 101 }
 102
 103 void
 104 initStorage( void )
 105 {
 106   nat g, s;
 107   generation *gen;
 108
 109   if (generations != NULL) {
 110       // multi-init protection
 111       return;
 112   }
 113
 114   initMBlocks();
 115
 116   /* Sanity check to make sure the LOOKS_LIKE_ macros appear to be
 117    * doing something reasonable.
 118    */
 119   ASSERT(LOOKS_LIKE_INFO_PTR(&stg_BLACKHOLE_info));
 120   ASSERT(LOOKS_LIKE_CLOSURE_PTR(&stg_dummy_ret_closure));
 121   ASSERT(!HEAP_ALLOCED(&stg_dummy_ret_closure));
 122
 123   if (RtsFlags.GcFlags.maxHeapSize != 0 &&
 124       RtsFlags.GcFlags.heapSizeSuggestion >
 125       RtsFlags.GcFlags.maxHeapSize) {
 126     RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion;
 127   }
 128
 129   if (RtsFlags.GcFlags.maxHeapSize != 0 &&
 130       RtsFlags.GcFlags.minAllocAreaSize >
 131       RtsFlags.GcFlags.maxHeapSize) {
 132       errorBelch("maximum heap size (-M) is smaller than minimum alloc area size (-A)");
 133       RtsFlags.GcFlags.minAllocAreaSize = RtsFlags.GcFlags.maxHeapSize;
 134   }
 135
 136   initBlockAllocator();
 137
 138 #if defined(THREADED_RTS)
 139   initMutex(&sm_mutex);
 140   initMutex(&atomic_modify_mutvar_mutex);
 141 #endif
 142
 143   ACQUIRE_SM_LOCK;
 144
 145   /* allocate generation info array */
 146   generations = (generation *)stgMallocBytes(RtsFlags.GcFlags.generations
 147                                              * sizeof(struct generation_),
 148                                              "initStorage: gens");
 149
 150   /* Initialise all generations */
 151   for(g = 0; g < RtsFlags.GcFlags.generations; g++) {
 152     gen = &generations[g];
 153     gen->no = g;
 154     gen->mut_list = allocBlock();
 155     gen->collections = 0;
 156     gen->failed_promotions = 0;
 157     gen->max_blocks = 0;
 158   }
 159
 160   /* A couple of convenience pointers */
 161   g0 = &generations[0];
 162   oldest_gen = &generations[RtsFlags.GcFlags.generations-1];
 163
 164   /* Allocate step structures in each generation */
 165   if (RtsFlags.GcFlags.generations > 1) {
 166     /* Only for multiple-generations */
 167
 168     /* Oldest generation: one step */
 169     oldest_gen->n_steps = 1;
 170     oldest_gen->steps =
 171       stgMallocBytes(1 * sizeof(struct step_), "initStorage: last step");
 172
 173     /* set up all except the oldest generation with 2 steps */
 174     for(g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
 175       generations[g].n_steps = RtsFlags.GcFlags.steps;
 176       generations[g].steps  =
 177         stgMallocBytes (RtsFlags.GcFlags.steps * sizeof(struct step_),
 178                         "initStorage: steps");
 179     }
 180
 181   } else {
 182     /* single generation, i.e. a two-space collector */
 183     g0->n_steps = 1;
 184     g0->steps = stgMallocBytes (sizeof(struct step_), "initStorage: steps");
 185   }
 186
 187 #ifdef THREADED_RTS
 188   n_nurseries = n_capabilities;
 189 #else
 190   n_nurseries = 1;
 191 #endif
 192   nurseries = stgMallocBytes (n_nurseries * sizeof(struct step_),
 193                               "initStorage: nurseries");
 194
 195   /* Initialise all steps */
 196   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 197     for (s = 0; s < generations[g].n_steps; s++) {
 198         initStep(&generations[g].steps[s], g, s);
 199     }
 200   }
 201
 202   for (s = 0; s < n_nurseries; s++) {
 203       initStep(&nurseries[s], 0, s);
 204   }
 205
 206   /* Set up the destination pointers in each younger gen. step */
 207   for (g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
 208     for (s = 0; s < generations[g].n_steps-1; s++) {
 209       generations[g].steps[s].to = &generations[g].steps[s+1];
 210     }
 211     generations[g].steps[s].to = &generations[g+1].steps[0];
 212   }
 213   oldest_gen->steps[0].to = &oldest_gen->steps[0];
 214
 215   for (s = 0; s < n_nurseries; s++) {
 216       nurseries[s].to = generations[0].steps[0].to;
 217   }
 218
 219   /* The oldest generation has one step. */
 220   if (RtsFlags.GcFlags.compact) {
 221       if (RtsFlags.GcFlags.generations == 1) {
 222           errorBelch("WARNING: compaction is incompatible with -G1; disabled");
 223       } else {
 224           oldest_gen->steps[0].is_compacted = 1;
 225       }
 226   }
 227
 228   generations[0].max_blocks = 0;
 229   g0s0 = &generations[0].steps[0];
 230
 231   /* The allocation area.  Policy: keep the allocation area
 232    * small to begin with, even if we have a large suggested heap
 233    * size.  Reason: we're going to do a major collection first, and we
 234    * don't want it to be a big one.  This vague idea is borne out by
 235    * rigorous experimental evidence.
 236    */
 237   allocNurseries();
 238
 239   weak_ptr_list = NULL;
 240   caf_list = NULL;
 241   revertible_caf_list = NULL;
 242
 243   /* initialise the allocate() interface */
 244   alloc_blocks = 0;
 245   alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
 246
 247   /* Tell GNU multi-precision pkg about our custom alloc functions */
 248   mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);
 249
 250   IF_DEBUG(gc, statDescribeGens());
 251
 252   RELEASE_SM_LOCK;
 253 }
 254
 255 void
 256 exitStorage (void)
 257 {
 258     stat_exit(calcAllocated());
 259 }
 260
 261 void
 262 freeStorage (void)
 263 {
 264     nat g;
 265
 266     for(g = 0; g < RtsFlags.GcFlags.generations; g++)
 267       stgFree(generations[g].steps);
 268     stgFree(generations);
 269     freeAllMBlocks();
 270 #if defined(THREADED_RTS)
 271     closeMutex(&sm_mutex);
 272     closeMutex(&atomic_modify_mutvar_mutex);
 273 #endif
 274     stgFree(nurseries);
 275 }
 276
 277 /* -----------------------------------------------------------------------------
 278    CAF management.
 279
 280    The entry code for every CAF does the following:
 281
 282       - builds a CAF_BLACKHOLE in the heap
 283       - pushes an update frame pointing to the CAF_BLACKHOLE
 284       - invokes UPD_CAF(), which:
 285           - calls newCaf, below
 286           - updates the CAF with a static indirection to the CAF_BLACKHOLE
 287
 288    Why do we build a BLACKHOLE in the heap rather than just updating
 289    the thunk directly?  It's so that we only need one kind of update
 290    frame - otherwise we'd need a static version of the update frame too.
 291
 292    newCaf() does the following:
 293
 294       - it puts the CAF on the oldest generation's mut-once list.
 295         This is so that we can treat the CAF as a root when collecting
 296         younger generations.
 297
 298    For GHCI, we have additional requirements when dealing with CAFs:
 299
 300       - we must *retain* all dynamically-loaded CAFs ever entered,
 301         just in case we need them again.
 302       - we must be able to *revert* CAFs that have been evaluated, to
 303         their pre-evaluated form.
 304
 305       To do this, we use an additional CAF list.  When newCaf() is
 306       called on a dynamically-loaded CAF, we add it to the CAF list
 307       instead of the old-generation mutable list, and save away its
 308       old info pointer (in caf->saved_info) for later reversion.
 309
 310       To revert all the CAFs, we traverse the CAF list and reset the
 311       info pointer to caf->saved_info, then throw away the CAF list.
 312       (see GC.c:revertCAFs()).
 313
 314       -- SDM 29/1/01
 315
 316    -------------------------------------------------------------------------- */
 317
 318 void
 319 newCAF(StgClosure* caf)
 320 {
 321   ACQUIRE_SM_LOCK;
 322
 323   if(keepCAFs)
 324   {
 325     // HACK:
 326     // If we are in GHCi _and_ we are using dynamic libraries,
 327     // then we can't redirect newCAF calls to newDynCAF (see below),
 328     // so we make newCAF behave almost like newDynCAF.
 329     // The dynamic libraries might be used by both the interpreted
 330     // program and GHCi itself, so they must not be reverted.
 331     // This also means that in GHCi with dynamic libraries, CAFs are not
 332     // garbage collected. If this turns out to be a problem, we could
 333     // do another hack here and do an address range test on caf to figure
 334     // out whether it is from a dynamic library.
 335     ((StgIndStatic *)caf)->saved_info  = (StgInfoTable *)caf->header.info;
 336     ((StgIndStatic *)caf)->static_link = caf_list;
 337     caf_list = caf;
 338   }
 339   else
 340   {
 341     /* Put this CAF on the mutable list for the old generation.
 342     * This is a HACK - the IND_STATIC closure doesn't really have
 343     * a mut_link field, but we pretend it has - in fact we re-use
 344     * the STATIC_LINK field for the time being, because when we
 345     * come to do a major GC we won't need the mut_link field
 346     * any more and can use it as a STATIC_LINK.
 347     */
 348     ((StgIndStatic *)caf)->saved_info = NULL;
 349     recordMutableGen(caf, oldest_gen);
 350   }
 351
 352   RELEASE_SM_LOCK;
 353 }
 354
 355 // An alternate version of newCaf which is used for dynamically loaded
 356 // object code in GHCi.  In this case we want to retain *all* CAFs in
 357 // the object code, because they might be demanded at any time from an
 358 // expression evaluated on the command line.
 359 // Also, GHCi might want to revert CAFs, so we add these to the
 360 // revertible_caf_list.
 361 //
 362 // The linker hackily arranges that references to newCaf from dynamic
 363 // code end up pointing to newDynCAF.
 364 void
 365 newDynCAF(StgClosure *caf)
 366 {
 367     ACQUIRE_SM_LOCK;
 368
 369     ((StgIndStatic *)caf)->saved_info  = (StgInfoTable *)caf->header.info;
 370     ((StgIndStatic *)caf)->static_link = revertible_caf_list;
 371     revertible_caf_list = caf;
 372
 373     RELEASE_SM_LOCK;
 374 }
 375
 376 /* -----------------------------------------------------------------------------
 377    Nursery management.
 378    -------------------------------------------------------------------------- */
 379
 380 static bdescr *
 381 allocNursery (step *stp, bdescr *tail, nat blocks)
 382 {
 383     bdescr *bd;
 384     nat i;
 385
 386     // Allocate a nursery: we allocate fresh blocks one at a time and
 387     // cons them on to the front of the list, not forgetting to update
 388     // the back pointer on the tail of the list to point to the new block.
 389     for (i=0; i < blocks; i++) {
 390         // @LDV profiling
 391         /*
 392           processNursery() in LdvProfile.c assumes that every block group in
 393           the nursery contains only a single block. So, if a block group is
 394           given multiple blocks, change processNursery() accordingly.
 395         */
 396         bd = allocBlock();
 397         bd->link = tail;
 398         // double-link the nursery: we might need to insert blocks
 399         if (tail != NULL) {
 400             tail->u.back = bd;
 401         }
 402         bd->step = stp;
 403         bd->gen_no = 0;
 404         bd->flags = 0;
 405         bd->free = bd->start;
 406         tail = bd;
 407     }
 408     tail->u.back = NULL;
 409     return tail;
 410 }
 411
 412 static void
 413 assignNurseriesToCapabilities (void)
 414 {
 415 #ifdef THREADED_RTS
 416     nat i;
 417
 418     for (i = 0; i < n_nurseries; i++) {
 419         capabilities[i].r.rNursery        = &nurseries[i];
 420         capabilities[i].r.rCurrentNursery = nurseries[i].blocks;
 421         capabilities[i].r.rCurrentAlloc   = NULL;
 422     }
 423 #else /* THREADED_RTS */
 424     MainCapability.r.rNursery        = &nurseries[0];
 425     MainCapability.r.rCurrentNursery = nurseries[0].blocks;
 426     MainCapability.r.rCurrentAlloc   = NULL;
 427 #endif
 428 }
 429
 430 void
 431 allocNurseries( void )
 432 {
 433     nat i;
 434
 435     for (i = 0; i < n_nurseries; i++) {
 436         nurseries[i].blocks =
 437             allocNursery(&nurseries[i], NULL,
 438                          RtsFlags.GcFlags.minAllocAreaSize);
 439         nurseries[i].n_blocks    = RtsFlags.GcFlags.minAllocAreaSize;
 440         nurseries[i].old_blocks   = NULL;
 441         nurseries[i].n_old_blocks = 0;
 442     }
 443     assignNurseriesToCapabilities();
 444 }
 445
 446 void
 447 resetNurseries( void )
 448 {
 449     nat i;
 450     bdescr *bd;
 451     step *stp;
 452
 453     for (i = 0; i < n_nurseries; i++) {
 454         stp = &nurseries[i];
 455         for (bd = stp->blocks; bd; bd = bd->link) {
 456             bd->free = bd->start;
 457             ASSERT(bd->gen_no == 0);
 458             ASSERT(bd->step == stp);
 459             IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
 460         }
 461     }
 462     assignNurseriesToCapabilities();
 463 }
 464
 465 lnat
 466 countNurseryBlocks (void)
 467 {
 468     nat i;
 469     lnat blocks = 0;
 470
 471     for (i = 0; i < n_nurseries; i++) {
 472         blocks += nurseries[i].n_blocks;
 473     }
 474     return blocks;
 475 }
 476
 477 static void
 478 resizeNursery ( step *stp, nat blocks )
 479 {
 480   bdescr *bd;
 481   nat nursery_blocks;
 482
 483   nursery_blocks = stp->n_blocks;
 484   if (nursery_blocks == blocks) return;
 485
 486   if (nursery_blocks < blocks) {
 487       debugTrace(DEBUG_gc, "increasing size of nursery to %d blocks",
 488                  blocks);
 489     stp->blocks = allocNursery(stp, stp->blocks, blocks-nursery_blocks);
 490   }
 491   else {
 492     bdescr *next_bd;
 493
 494     debugTrace(DEBUG_gc, "decreasing size of nursery to %d blocks",
 495                blocks);
 496
 497     bd = stp->blocks;
 498     while (nursery_blocks > blocks) {
 499         next_bd = bd->link;
 500         next_bd->u.back = NULL;
 501         nursery_blocks -= bd->blocks; // might be a large block
 502         freeGroup(bd);
 503         bd = next_bd;
 504     }
 505     stp->blocks = bd;
 506     // might have gone just under, by freeing a large block, so make
 507     // up the difference.
 508     if (nursery_blocks < blocks) {
 509         stp->blocks = allocNursery(stp, stp->blocks, blocks-nursery_blocks);
 510     }
 511   }
 512
 513   stp->n_blocks = blocks;
 514   ASSERT(countBlocks(stp->blocks) == stp->n_blocks);
 515 }
 516
 517 //
 518 // Resize each of the nurseries to the specified size.
 519 //
 520 void
 521 resizeNurseriesFixed (nat blocks)
 522 {
 523     nat i;
 524     for (i = 0; i < n_nurseries; i++) {
 525         resizeNursery(&nurseries[i], blocks);
 526     }
 527 }
 528
 529 //
 530 // Resize the nurseries to the total specified size.
 531 //
 532 void
 533 resizeNurseries (nat blocks)
 534 {
 535     // If there are multiple nurseries, then we just divide the number
 536     // of available blocks between them.
 537     resizeNurseriesFixed(blocks / n_nurseries);
 538 }
 539
 540 /* -----------------------------------------------------------------------------
 541    The allocate() interface
 542
 543    allocateInGen() function allocates memory directly into a specific
 544    generation.  It always succeeds, and returns a chunk of memory n
 545    words long.  n can be larger than the size of a block if necessary,
 546    in which case a contiguous block group will be allocated.
 547
 548    allocate(n) is equivalent to allocateInGen(g0).
 549    -------------------------------------------------------------------------- */
 550
 551 StgPtr
 552 allocateInGen (generation *g, nat n)
 553 {
 554     step *stp;
 555     bdescr *bd;
 556     StgPtr ret;
 557
 558     ACQUIRE_SM_LOCK;
 559
 560     TICK_ALLOC_HEAP_NOCTR(n);
 561     CCS_ALLOC(CCCS,n);
 562
 563     stp = &g->steps[0];
 564
 565     if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_))
 566     {
 567         nat req_blocks =  (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
 568
 569         // Attempting to allocate an object larger than maxHeapSize
 570         // should definitely be disallowed.  (bug #1791)
 571         if (RtsFlags.GcFlags.maxHeapSize > 0 &&
 572             req_blocks >= RtsFlags.GcFlags.maxHeapSize) {
 573             heapOverflow();
 574         }
 575
 576         bd = allocGroup(req_blocks);
 577         dbl_link_onto(bd, &stp->large_objects);
 578         stp->n_large_blocks += bd->blocks; // might be larger than req_blocks
 579         bd->gen_no  = g->no;
 580         bd->step = stp;
 581         bd->flags = BF_LARGE;
 582         bd->free = bd->start + n;
 583         ret = bd->start;
 584     }
 585     else
 586     {
 587         // small allocation (<LARGE_OBJECT_THRESHOLD) */
 588         bd = stp->blocks;
 589         if (bd == NULL || bd->free + n > bd->start + BLOCK_SIZE_W) {
 590             bd = allocBlock();
 591             bd->gen_no = g->no;
 592             bd->step = stp;
 593             bd->flags = 0;
 594             bd->link = stp->blocks;
 595             stp->blocks = bd;
 596             stp->n_blocks++;
 597             alloc_blocks++;
 598         }
 599         ret = bd->free;
 600         bd->free += n;
 601     }
 602
 603     RELEASE_SM_LOCK;
 604
 605     return ret;
 606 }
 607
 608 StgPtr
 609 allocate (nat n)
 610 {
 611     return allocateInGen(g0,n);
 612 }
 613
 614 lnat
 615 allocatedBytes( void )
 616 {
 617     lnat allocated;
 618
 619     allocated = alloc_blocks * BLOCK_SIZE_W;
 620     if (pinned_object_block != NULL) {
 621         allocated -= (pinned_object_block->start + BLOCK_SIZE_W) -
 622             pinned_object_block->free;
 623     }
 624
 625     return allocated;
 626 }
 627
 628 /* -----------------------------------------------------------------------------
 629    allocateLocal()
 630
 631    This allocates memory in the current thread - it is intended for
 632    use primarily from STG-land where we have a Capability.  It is
 633    better than allocate() because it doesn't require taking the
 634    sm_mutex lock in the common case.
 635
 636    Memory is allocated directly from the nursery if possible (but not
 637    from the current nursery block, so as not to interfere with
 638    Hp/HpLim).
 639    -------------------------------------------------------------------------- */
 640
 641 StgPtr
 642 allocateLocal (Capability *cap, nat n)
 643 {
 644     bdescr *bd;
 645     StgPtr p;
 646
 647     if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
 648         return allocateInGen(g0,n);
 649     }
 650
 651     /* small allocation (<LARGE_OBJECT_THRESHOLD) */
 652
 653     TICK_ALLOC_HEAP_NOCTR(n);
 654     CCS_ALLOC(CCCS,n);
 655
 656     bd = cap->r.rCurrentAlloc;
 657     if (bd == NULL || bd->free + n > bd->start + BLOCK_SIZE_W) {
 658
 659         // The CurrentAlloc block is full, we need to find another
 660         // one.  First, we try taking the next block from the
 661         // nursery:
 662         bd = cap->r.rCurrentNursery->link;
 663
 664         if (bd == NULL || bd->free + n > bd->start + BLOCK_SIZE_W) {
 665             // The nursery is empty, or the next block is already
 666             // full: allocate a fresh block (we can't fail here).
 667             ACQUIRE_SM_LOCK;
 668             bd = allocBlock();
 669             cap->r.rNursery->n_blocks++;
 670             RELEASE_SM_LOCK;
 671             bd->gen_no = 0;
 672             bd->step = cap->r.rNursery;
 673             bd->flags = 0;
 674             // NO: alloc_blocks++;
 675             // calcAllocated() uses the size of the nursery, and we've
 676             // already bumpted nursery->n_blocks above.
 677         } else {
 678             // we have a block in the nursery: take it and put
 679             // it at the *front* of the nursery list, and use it
 680             // to allocate() from.
 681             cap->r.rCurrentNursery->link = bd->link;
 682             if (bd->link != NULL) {
 683                 bd->link->u.back = cap->r.rCurrentNursery;
 684             }
 685         }
 686         dbl_link_onto(bd, &cap->r.rNursery->blocks);
 687         cap->r.rCurrentAlloc = bd;
 688         IF_DEBUG(sanity, checkNurserySanity(cap->r.rNursery));
 689     }
 690     p = bd->free;
 691     bd->free += n;
 692     return p;
 693 }
 694
 695 /* ---------------------------------------------------------------------------
 696    Allocate a fixed/pinned object.
 697
 698    We allocate small pinned objects into a single block, allocating a
 699    new block when the current one overflows.  The block is chained
 700    onto the large_object_list of generation 0 step 0.
 701
 702    NOTE: The GC can't in general handle pinned objects.  This
 703    interface is only safe to use for ByteArrays, which have no
 704    pointers and don't require scavenging.  It works because the
 705    block's descriptor has the BF_LARGE flag set, so the block is
 706    treated as a large object and chained onto various lists, rather
 707    than the individual objects being copied.  However, when it comes
 708    to scavenge the block, the GC will only scavenge the first object.
 709    The reason is that the GC can't linearly scan a block of pinned
 710    objects at the moment (doing so would require using the
 711    mostly-copying techniques).  But since we're restricting ourselves
 712    to pinned ByteArrays, not scavenging is ok.
 713
 714    This function is called by newPinnedByteArray# which immediately
 715    fills the allocated memory with a MutableByteArray#.
 716    ------------------------------------------------------------------------- */
 717
 718 StgPtr
 719 allocatePinned( nat n )
 720 {
 721     StgPtr p;
 722     bdescr *bd = pinned_object_block;
 723
 724     // If the request is for a large object, then allocate()
 725     // will give us a pinned object anyway.
 726     if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
 727         return allocate(n);
 728     }
 729
 730     ACQUIRE_SM_LOCK;
 731
 732     TICK_ALLOC_HEAP_NOCTR(n);
 733     CCS_ALLOC(CCCS,n);
 734
 735     // we always return 8-byte aligned memory.  bd->free must be
 736     // 8-byte aligned to begin with, so we just round up n to
 737     // the nearest multiple of 8 bytes.
 738     if (sizeof(StgWord) == 4) {
 739         n = (n+1) & ~1;
 740     }
 741
 742     // If we don't have a block of pinned objects yet, or the current
 743     // one isn't large enough to hold the new object, allocate a new one.
 744     if (bd == NULL || (bd->free + n) > (bd->start + BLOCK_SIZE_W)) {
 745         pinned_object_block = bd = allocBlock();
 746         dbl_link_onto(bd, &g0s0->large_objects);
 747         g0s0->n_large_blocks++;
 748         bd->gen_no = 0;
 749         bd->step   = g0s0;
 750         bd->flags  = BF_PINNED | BF_LARGE;
 751         bd->free   = bd->start;
 752         alloc_blocks++;
 753     }
 754
 755     p = bd->free;
 756     bd->free += n;
 757     RELEASE_SM_LOCK;
 758     return p;
 759 }
 760
 761 /* -----------------------------------------------------------------------------
 762    Write Barriers
 763    -------------------------------------------------------------------------- */
 764
 765 /*
 766    This is the write barrier for MUT_VARs, a.k.a. IORefs.  A
 767    MUT_VAR_CLEAN object is not on the mutable list; a MUT_VAR_DIRTY
 768    is.  When written to, a MUT_VAR_CLEAN turns into a MUT_VAR_DIRTY
 769    and is put on the mutable list.
 770 */
 771 void
 772 dirty_MUT_VAR(StgRegTable *reg, StgClosure *p)
 773 {
 774     Capability *cap = regTableToCapability(reg);
 775     bdescr *bd;
 776     if (p->header.info == &stg_MUT_VAR_CLEAN_info) {
 777         p->header.info = &stg_MUT_VAR_DIRTY_info;
 778         bd = Bdescr((StgPtr)p);
 779         if (bd->gen_no > 0) recordMutableCap(p,cap,bd->gen_no);
 780     }
 781 }
 782
 783 /*
 784    This is the write barrier for MVARs.  An MVAR_CLEAN objects is not
 785    on the mutable list; a MVAR_DIRTY is.  When written to, a
 786    MVAR_CLEAN turns into a MVAR_DIRTY and is put on the mutable list.
 787    The check for MVAR_CLEAN is inlined at the call site for speed,
 788    this really does make a difference on concurrency-heavy benchmarks
 789    such as Chaneneos and cheap-concurrency.
 790 */
 791 void
 792 dirty_MVAR(StgRegTable *reg, StgClosure *p)
 793 {
 794     Capability *cap = regTableToCapability(reg);
 795     bdescr *bd;
 796     bd = Bdescr((StgPtr)p);
 797     if (bd->gen_no > 0) recordMutableCap(p,cap,bd->gen_no);
 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     if (bd->gen_no == 0) {
1050         // Free the block if it is empty, but not if it is the block at
1051         // the head of the queue.
1052         if (bd != exec_block) {
1053             debugTrace(DEBUG_gc, "free exec block %p", bd->start);
1054             dbl_link_remove(bd, &exec_block);
1055             setExecutable(bd->start, bd->blocks * BLOCK_SIZE, rtsFalse);
1056             freeGroup(bd);
1057         } else {
1058             bd->free = bd->start;
1059         }
1060     }
1061
1062     RELEASE_SM_LOCK
1063 }
1064
1065 /* -----------------------------------------------------------------------------
1066    Debugging
1067
1068    memInventory() checks for memory leaks by counting up all the
1069    blocks we know about and comparing that to the number of blocks
1070    allegedly floating around in the system.
1071    -------------------------------------------------------------------------- */
1072
1073 #ifdef DEBUG
1074
1075 nat
1076 countBlocks(bdescr *bd)
1077 {
1078     nat n;
1079     for (n=0; bd != NULL; bd=bd->link) {
1080         n += bd->blocks;
1081     }
1082     return n;
1083 }
1084
1085 // (*1) Just like countBlocks, except that we adjust the count for a
1086 // megablock group so that it doesn't include the extra few blocks
1087 // that would be taken up by block descriptors in the second and
1088 // subsequent megablock.  This is so we can tally the count with the
1089 // number of blocks allocated in the system, for memInventory().
1090 static nat
1091 countAllocdBlocks(bdescr *bd)
1092 {
1093     nat n;
1094     for (n=0; bd != NULL; bd=bd->link) {
1095         n += bd->blocks;
1096         // hack for megablock groups: see (*1) above
1097         if (bd->blocks > BLOCKS_PER_MBLOCK) {
1098             n -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
1099                 * (bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE));
1100         }
1101     }
1102     return n;
1103 }
1104
1105 static lnat
1106 stepBlocks (step *stp)
1107 {
1108     ASSERT(countBlocks(stp->blocks) == stp->n_blocks);
1109     ASSERT(countBlocks(stp->large_objects) == stp->n_large_blocks);
1110     return stp->n_blocks + stp->n_old_blocks +
1111             countAllocdBlocks(stp->large_objects);
1112 }
1113
1114 void
1115 memInventory(void)
1116 {
1117   nat g, s, i;
1118   step *stp;
1119   lnat gen_blocks[RtsFlags.GcFlags.generations];
1120   lnat nursery_blocks, retainer_blocks,
1121        arena_blocks, exec_blocks;
1122   lnat live_blocks = 0, free_blocks = 0;
1123
1124   // count the blocks we current have
1125
1126   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1127       gen_blocks[g] = 0;
1128       for (i = 0; i < n_capabilities; i++) {
1129           gen_blocks[g] += countBlocks(capabilities[i].mut_lists[g]);
1130       }
1131       gen_blocks[g] += countAllocdBlocks(generations[g].mut_list);
1132       for (s = 0; s < generations[g].n_steps; s++) {
1133           stp = &generations[g].steps[s];
1134           gen_blocks[g] += stepBlocks(stp);
1135       }
1136   }
1137
1138   nursery_blocks = 0;
1139   for (i = 0; i < n_nurseries; i++) {
1140       nursery_blocks += stepBlocks(&nurseries[i]);
1141   }
1142
1143   retainer_blocks = 0;
1144 #ifdef PROFILING
1145   if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_RETAINER) {
1146       retainer_blocks = retainerStackBlocks();
1147   }
1148 #endif
1149
1150   // count the blocks allocated by the arena allocator
1151   arena_blocks = arenaBlocks();
1152
1153   // count the blocks containing executable memory
1154   exec_blocks = countAllocdBlocks(exec_block);
1155
1156   /* count the blocks on the free list */
1157   free_blocks = countFreeList();
1158
1159   live_blocks = 0;
1160   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1161       live_blocks += gen_blocks[g];
1162   }
1163   live_blocks += nursery_blocks +
1164                + retainer_blocks + arena_blocks + exec_blocks;
1165
1166   if (live_blocks + free_blocks != mblocks_allocated * BLOCKS_PER_MBLOCK)
1167   {
1168       debugBelch("Memory leak detected\n");
1169       for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1170           debugBelch("  gen %d blocks : %4lu\n", g, gen_blocks[g]);
1171       }
1172       debugBelch("  nursery      : %4lu\n", nursery_blocks);
1173       debugBelch("  retainer     : %4lu\n", retainer_blocks);
1174       debugBelch("  arena blocks : %4lu\n", arena_blocks);
1175       debugBelch("  exec         : %4lu\n", exec_blocks);
1176       debugBelch("  free         : %4lu\n", free_blocks);
1177       debugBelch("  total        : %4lu\n\n", live_blocks + free_blocks);
1178       debugBelch("  in system    : %4lu\n", mblocks_allocated * BLOCKS_PER_MBLOCK);
1179       ASSERT(0);
1180   }
1181 }
1182
1183
1184 /* Full heap sanity check. */
1185 void
1186 checkSanity( void )
1187 {
1188     nat g, s;
1189
1190     if (RtsFlags.GcFlags.generations == 1) {
1191         checkHeap(g0s0->blocks);
1192         checkChain(g0s0->large_objects);
1193     } else {
1194
1195         for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1196             for (s = 0; s < generations[g].n_steps; s++) {
1197                 if (g == 0 && s == 0) { continue; }
1198                 ASSERT(countBlocks(generations[g].steps[s].blocks)
1199                        == generations[g].steps[s].n_blocks);
1200                 ASSERT(countBlocks(generations[g].steps[s].large_objects)
1201                        == generations[g].steps[s].n_large_blocks);
1202                 checkHeap(generations[g].steps[s].blocks);
1203                 checkChain(generations[g].steps[s].large_objects);
1204                 if (g > 0) {
1205                     checkMutableList(generations[g].mut_list, g);
1206                 }
1207             }
1208         }
1209
1210         for (s = 0; s < n_nurseries; s++) {
1211             ASSERT(countBlocks(nurseries[s].blocks)
1212                    == nurseries[s].n_blocks);
1213             ASSERT(countBlocks(nurseries[s].large_objects)
1214                    == nurseries[s].n_large_blocks);
1215         }
1216
1217         checkFreeListSanity();
1218     }
1219 }
1220
1221 /* Nursery sanity check */
1222 void
1223 checkNurserySanity( step *stp )
1224 {
1225     bdescr *bd, *prev;
1226     nat blocks = 0;
1227
1228     prev = NULL;
1229     for (bd = stp->blocks; bd != NULL; bd = bd->link) {
1230         ASSERT(bd->u.back == prev);
1231         prev = bd;
1232         blocks += bd->blocks;
1233     }
1234     ASSERT(blocks == stp->n_blocks);
1235 }
1236
1237 // handy function for use in gdb, because Bdescr() is inlined.
1238 extern bdescr *_bdescr( StgPtr p );
1239
1240 bdescr *
1241 _bdescr( StgPtr p )
1242 {
1243     return Bdescr(p);
1244 }
1245
1246 #endif