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