rts/Storage.c

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