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