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