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 += bd->blocks; // might be larger than 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 += bd->blocks; // might be larger than 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         g0s0->n_large_blocks++;
 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       return (g0s0->n_large_blocks + g0s0->n_blocks) * BLOCK_SIZE_W;
 921   }
 922
 923   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 924     for (s = 0; s < generations[g].n_steps; s++) {
 925       /* approximate amount of live data (doesn't take into account slop
 926        * at end of each block).
 927        */
 928       if (g == 0 && s == 0) {
 929           continue;
 930       }
 931       stp = &generations[g].steps[s];
 932       live += (stp->n_large_blocks + stp->n_blocks) * BLOCK_SIZE_W;
 933     }
 934   }
 935   return live;
 936 }
 937
 938 /* Approximate the number of blocks that will be needed at the next
 939  * garbage collection.
 940  *
 941  * Assume: all data currently live will remain live.  Steps that will
 942  * be collected next time will therefore need twice as many blocks
 943  * since all the data will be copied.
 944  */
 945 extern lnat
 946 calcNeeded(void)
 947 {
 948     lnat needed = 0;
 949     nat g, s;
 950     step *stp;
 951
 952     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 953         for (s = 0; s < generations[g].n_steps; s++) {
 954             if (g == 0 && s == 0) { continue; }
 955             stp = &generations[g].steps[s];
 956             if (generations[g].steps[0].n_blocks +
 957                 generations[g].steps[0].n_large_blocks
 958                 > generations[g].max_blocks
 959                 && stp->is_compacted == 0) {
 960                 needed += 2 * stp->n_blocks;
 961             } else {
 962                 needed += stp->n_blocks;
 963             }
 964         }
 965     }
 966     return needed;
 967 }
 968
 969 /* ----------------------------------------------------------------------------
 970    Executable memory
 971
 972    Executable memory must be managed separately from non-executable
 973    memory.  Most OSs these days require you to jump through hoops to
 974    dynamically allocate executable memory, due to various security
 975    measures.
 976
 977    Here we provide a small memory allocator for executable memory.
 978    Memory is managed with a page granularity; we allocate linearly
 979    in the page, and when the page is emptied (all objects on the page
 980    are free) we free the page again, not forgetting to make it
 981    non-executable.
 982    ------------------------------------------------------------------------- */
 983
 984 static bdescr *exec_block;
 985
 986 void *allocateExec (nat bytes)
 987 {
 988     void *ret;
 989     nat n;
 990
 991     ACQUIRE_SM_LOCK;
 992
 993     // round up to words.
 994     n  = (bytes + sizeof(W_) + 1) / sizeof(W_);
 995
 996     if (n+1 > BLOCK_SIZE_W) {
 997         barf("allocateExec: can't handle large objects");
 998     }
 999
1000     if (exec_block == NULL ||
1001         exec_block->free + n + 1 > exec_block->start + BLOCK_SIZE_W) {
1002         bdescr *bd;
1003         lnat pagesize = getPageSize();
1004         bd = allocGroup(stg_max(1, pagesize / BLOCK_SIZE));
1005         debugTrace(DEBUG_gc, "allocate exec block %p", bd->start);
1006         bd->gen_no = 0;
1007         bd->flags = BF_EXEC;
1008         bd->link = exec_block;
1009         if (exec_block != NULL) {
1010             exec_block->u.back = bd;
1011         }
1012         bd->u.back = NULL;
1013         setExecutable(bd->start, bd->blocks * BLOCK_SIZE, rtsTrue);
1014         exec_block = bd;
1015     }
1016     *(exec_block->free) = n;  // store the size of this chunk
1017     exec_block->gen_no += n;  // gen_no stores the number of words allocated
1018     ret = exec_block->free + 1;
1019     exec_block->free += n + 1;
1020
1021     RELEASE_SM_LOCK
1022     return ret;
1023 }
1024
1025 void freeExec (void *addr)
1026 {
1027     StgPtr p = (StgPtr)addr - 1;
1028     bdescr *bd = Bdescr((StgPtr)p);
1029
1030     if ((bd->flags & BF_EXEC) == 0) {
1031         barf("freeExec: not executable");
1032     }
1033
1034     if (*(StgPtr)p == 0) {
1035         barf("freeExec: already free?");
1036     }
1037
1038     ACQUIRE_SM_LOCK;
1039
1040     bd->gen_no -= *(StgPtr)p;
1041     *(StgPtr)p = 0;
1042
1043     // Free the block if it is empty, but not if it is the block at
1044     // the head of the queue.
1045     if (bd->gen_no == 0 && bd != exec_block) {
1046         debugTrace(DEBUG_gc, "free exec block %p", bd->start);
1047         if (bd->u.back) {
1048             bd->u.back->link = bd->link;
1049         } else {
1050             exec_block = bd->link;
1051         }
1052         if (bd->link) {
1053             bd->link->u.back = bd->u.back;
1054         }
1055         setExecutable(bd->start, bd->blocks * BLOCK_SIZE, rtsFalse);
1056         freeGroup(bd);
1057     }
1058
1059     RELEASE_SM_LOCK
1060 }
1061
1062 /* -----------------------------------------------------------------------------
1063    Debugging
1064
1065    memInventory() checks for memory leaks by counting up all the
1066    blocks we know about and comparing that to the number of blocks
1067    allegedly floating around in the system.
1068    -------------------------------------------------------------------------- */
1069
1070 #ifdef DEBUG
1071
1072 nat
1073 countBlocks(bdescr *bd)
1074 {
1075     nat n;
1076     for (n=0; bd != NULL; bd=bd->link) {
1077         n += bd->blocks;
1078     }
1079     return n;
1080 }
1081
1082 // (*1) Just like countBlocks, except that we adjust the count for a
1083 // megablock group so that it doesn't include the extra few blocks
1084 // that would be taken up by block descriptors in the second and
1085 // subsequent megablock.  This is so we can tally the count with the
1086 // number of blocks allocated in the system, for memInventory().
1087 static nat
1088 countAllocdBlocks(bdescr *bd)
1089 {
1090     nat n;
1091     for (n=0; bd != NULL; bd=bd->link) {
1092         n += bd->blocks;
1093         // hack for megablock groups: see (*1) above
1094         if (bd->blocks > BLOCKS_PER_MBLOCK) {
1095             n -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
1096                 * (bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE));
1097         }
1098     }
1099     return n;
1100 }
1101
1102 static lnat
1103 stepBlocks (step *stp)
1104 {
1105     ASSERT(countBlocks(stp->blocks) == stp->n_blocks);
1106     ASSERT(countBlocks(stp->large_objects) == stp->n_large_blocks);
1107     return stp->n_blocks + stp->n_old_blocks +
1108             countAllocdBlocks(stp->large_objects);
1109 }
1110
1111 void
1112 memInventory(void)
1113 {
1114   nat g, s, i;
1115   step *stp;
1116   lnat gen_blocks[RtsFlags.GcFlags.generations];
1117   lnat nursery_blocks, allocate_blocks, retainer_blocks,
1118        arena_blocks, exec_blocks;
1119   lnat live_blocks = 0, free_blocks = 0;
1120
1121   // count the blocks we current have
1122
1123   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1124       gen_blocks[g] = 0;
1125       for (i = 0; i < n_capabilities; i++) {
1126           gen_blocks[g] += countBlocks(capabilities[i].mut_lists[g]);
1127       }
1128       gen_blocks[g] += countAllocdBlocks(generations[g].mut_list);
1129       for (s = 0; s < generations[g].n_steps; s++) {
1130 #if !defined(THREADED_RTS)
1131           // We put pinned object blocks in g0s0, so better count
1132           // blocks there too.
1133           if (g==0 && s==0) continue;
1134 #endif
1135           stp = &generations[g].steps[s];
1136           gen_blocks[g] += stepBlocks(stp);
1137       }
1138   }
1139
1140   nursery_blocks = 0;
1141   for (i = 0; i < n_nurseries; i++) {
1142       nursery_blocks += stepBlocks(&nurseries[i]);
1143   }
1144
1145   /* any blocks held by allocate() */
1146   allocate_blocks = countAllocdBlocks(small_alloc_list);
1147
1148   retainer_blocks = 0;
1149 #ifdef PROFILING
1150   if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_RETAINER) {
1151       retainer_blocks = retainerStackBlocks();
1152   }
1153 #endif
1154
1155   // count the blocks allocated by the arena allocator
1156   arena_blocks = arenaBlocks();
1157
1158   // count the blocks containing executable memory
1159   exec_blocks = countAllocdBlocks(exec_block);
1160
1161   /* count the blocks on the free list */
1162   free_blocks = countFreeList();
1163
1164   live_blocks = 0;
1165   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1166       live_blocks += gen_blocks[g];
1167   }
1168   live_blocks += nursery_blocks + allocate_blocks
1169                + retainer_blocks + arena_blocks + exec_blocks;
1170
1171   if (live_blocks + free_blocks != mblocks_allocated * BLOCKS_PER_MBLOCK)
1172   {
1173       debugBelch("Memory leak detected\n");
1174       for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1175           debugBelch("  gen %d blocks : %4lu\n", g, gen_blocks[g]);
1176       }
1177       debugBelch("  nursery      : %4lu\n", nursery_blocks);
1178       debugBelch("  allocate()   : %4lu\n", allocate_blocks);
1179       debugBelch("  retainer     : %4lu\n", retainer_blocks);
1180       debugBelch("  arena blocks : %4lu\n", arena_blocks);
1181       debugBelch("  exec         : %4lu\n", exec_blocks);
1182       debugBelch("  free         : %4lu\n", free_blocks);
1183       debugBelch("  total        : %4lu\n\n", live_blocks + free_blocks);
1184       debugBelch("  in system    : %4lu\n", mblocks_allocated + BLOCKS_PER_MBLOCK);
1185       ASSERT(0);
1186   }
1187 }
1188
1189
1190 /* Full heap sanity check. */
1191 void
1192 checkSanity( void )
1193 {
1194     nat g, s;
1195
1196     if (RtsFlags.GcFlags.generations == 1) {
1197         checkHeap(g0s0->blocks);
1198         checkChain(g0s0->large_objects);
1199     } else {
1200
1201         for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1202             for (s = 0; s < generations[g].n_steps; s++) {
1203                 if (g == 0 && s == 0) { continue; }
1204                 ASSERT(countBlocks(generations[g].steps[s].blocks)
1205                        == generations[g].steps[s].n_blocks);
1206                 ASSERT(countBlocks(generations[g].steps[s].large_objects)
1207                        == generations[g].steps[s].n_large_blocks);
1208                 checkHeap(generations[g].steps[s].blocks);
1209                 checkChain(generations[g].steps[s].large_objects);
1210                 if (g > 0) {
1211                     checkMutableList(generations[g].mut_list, g);
1212                 }
1213             }
1214         }
1215
1216         for (s = 0; s < n_nurseries; s++) {
1217             ASSERT(countBlocks(nurseries[s].blocks)
1218                    == nurseries[s].n_blocks);
1219             ASSERT(countBlocks(nurseries[s].large_objects)
1220                    == nurseries[s].n_large_blocks);
1221         }
1222
1223         checkFreeListSanity();
1224     }
1225 }
1226
1227 /* Nursery sanity check */
1228 void
1229 checkNurserySanity( step *stp )
1230 {
1231     bdescr *bd, *prev;
1232     nat blocks = 0;
1233
1234     prev = NULL;
1235     for (bd = stp->blocks; bd != NULL; bd = bd->link) {
1236         ASSERT(bd->u.back == prev);
1237         prev = bd;
1238         blocks += bd->blocks;
1239     }
1240     ASSERT(blocks == stp->n_blocks);
1241 }
1242
1243 // handy function for use in gdb, because Bdescr() is inlined.
1244 extern bdescr *_bdescr( StgPtr p );
1245
1246 bdescr *
1247 _bdescr( StgPtr p )
1248 {
1249     return Bdescr(p);
1250 }
1251
1252 #endif