ghc/rts/Storage.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Storage.c,v 1.7 1999/01/26 16:16:30 simonm Exp $
   3  *
   4  * Storage manager front end
   5  *
   6  * ---------------------------------------------------------------------------*/
   7
   8 #include "Rts.h"
   9 #include "RtsUtils.h"
  10 #include "RtsFlags.h"
  11 #include "Stats.h"
  12 #include "Hooks.h"
  13 #include "BlockAlloc.h"
  14 #include "MBlock.h"
  15 #include "gmp.h"
  16 #include "Weak.h"
  17
  18 #include "Storage.h"
  19 #include "StoragePriv.h"
  20
  21 bdescr *current_nursery;        /* next available nursery block, or NULL */
  22 nat nursery_blocks;             /* number of blocks in the nursery */
  23
  24 StgClosure    *caf_list         = NULL;
  25
  26 bdescr *small_alloc_list;       /* allocate()d small objects */
  27 bdescr *large_alloc_list;       /* allocate()d large objects */
  28 nat alloc_blocks;               /* number of allocate()d blocks since GC */
  29 nat alloc_blocks_lim;           /* approximate limit on alloc_blocks */
  30
  31 StgPtr alloc_Hp    = NULL;      /* next free byte in small_alloc_list */
  32 StgPtr alloc_HpLim = NULL;      /* end of block at small_alloc_list   */
  33
  34 generation *generations;        /* all the generations */
  35 generation *g0;                 /* generation 0, for convenience */
  36 generation *oldest_gen;         /* oldest generation, for convenience */
  37 step *g0s0;                     /* generation 0, step 0, for convenience */
  38
  39 /*
  40  * Forward references
  41  */
  42 static void *stgAllocForGMP   (size_t size_in_bytes);
  43 static void *stgReallocForGMP (void *ptr, size_t old_size, size_t new_size);
  44 static void  stgDeallocForGMP (void *ptr, size_t size);
  45
  46 void
  47 initStorage (void)
  48 {
  49   nat g, s;
  50   step *step;
  51   generation *gen;
  52
  53   initBlockAllocator();
  54
  55   /* allocate generation info array */
  56   generations = (generation *)stgMallocBytes(RtsFlags.GcFlags.generations
  57                                              * sizeof(struct _generation),
  58                                              "initStorage: gens");
  59
  60   /* Initialise all generations */
  61   for(g = 0; g < RtsFlags.GcFlags.generations; g++) {
  62     gen = &generations[g];
  63     gen->no = g;
  64     gen->mut_list = END_MUT_LIST;
  65     gen->collections = 0;
  66     gen->failed_promotions = 0;
  67     gen->max_blocks = RtsFlags.GcFlags.minOldGenSize;
  68   }
  69
  70   /* A couple of convenience pointers */
  71   g0 = &generations[0];
  72   oldest_gen = &generations[RtsFlags.GcFlags.generations-1];
  73
  74   /* Allocate step structures in each generation */
  75   if (RtsFlags.GcFlags.generations > 1) {
  76     /* Only for multiple-generations */
  77
  78     /* Oldest generation: one step */
  79     oldest_gen->n_steps = 1;
  80     oldest_gen->steps =
  81       stgMallocBytes(1 * sizeof(struct _step), "initStorage: last step");
  82
  83     /* set up all except the oldest generation with 2 steps */
  84     for(g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
  85       generations[g].n_steps = RtsFlags.GcFlags.steps;
  86       generations[g].steps  =
  87         stgMallocBytes (RtsFlags.GcFlags.steps * sizeof(struct _step),
  88                         "initStorage: steps");
  89     }
  90
  91   } else {
  92     /* single generation, i.e. a two-space collector */
  93     g0->n_steps = 1;
  94     g0->steps = stgMallocBytes (sizeof(struct _step), "initStorage: steps");
  95   }
  96
  97   /* Initialise all steps */
  98   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
  99     for (s = 0; s < generations[g].n_steps; s++) {
 100       step = &generations[g].steps[s];
 101       step->no = s;
 102       step->blocks = NULL;
 103       step->n_blocks = 0;
 104       step->gen = &generations[g];
 105       step->hp = NULL;
 106       step->hpLim = NULL;
 107       step->hp_bd = NULL;
 108       step->large_objects = NULL;
 109       step->new_large_objects = NULL;
 110       step->scavenged_large_objects = NULL;
 111     }
 112   }
 113
 114   /* Set up the destination pointers in each younger gen. step */
 115   for (g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
 116     for (s = 0; s < generations[g].n_steps-1; s++) {
 117       generations[g].steps[s].to = &generations[g].steps[s+1];
 118     }
 119     generations[g].steps[s].to = &generations[g+1].steps[0];
 120   }
 121
 122   /* The oldest generation has one step and its destination is the
 123    * same step. */
 124   oldest_gen->steps[0].to = &oldest_gen->steps[0];
 125
 126   /* generation 0 is special: that's the nursery */
 127   generations[0].max_blocks = 0;
 128
 129   /* G0S0: the allocation area */
 130   step = &generations[0].steps[0];
 131   g0s0 = step;
 132   step->blocks   = allocNursery(NULL, RtsFlags.GcFlags.minAllocAreaSize);
 133   step->n_blocks = RtsFlags.GcFlags.minAllocAreaSize;
 134   nursery_blocks = RtsFlags.GcFlags.minAllocAreaSize;
 135   current_nursery = step->blocks;
 136   /* hp, hpLim, hp_bd, to_space etc. aren't used in G0S0 */
 137
 138   weak_ptr_list = NULL;
 139   caf_list = NULL;
 140
 141   /* initialise the allocate() interface */
 142   small_alloc_list = NULL;
 143   large_alloc_list = NULL;
 144   alloc_blocks = 0;
 145   alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
 146
 147 #ifdef COMPILER
 148   /* Tell GNU multi-precision pkg about our custom alloc functions */
 149   mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);
 150 #endif
 151
 152   IF_DEBUG(gc, stat_describe_gens());
 153 }
 154
 155 extern bdescr *
 156 allocNursery (bdescr *last_bd, nat blocks)
 157 {
 158   bdescr *bd;
 159   nat i;
 160
 161   /* Allocate a nursery */
 162   for (i=0; i < blocks; i++) {
 163     bd = allocBlock();
 164     bd->link = last_bd;
 165     bd->step = g0s0;
 166     bd->gen = g0;
 167     bd->evacuated = 0;
 168     bd->free = bd->start;
 169     last_bd = bd;
 170   }
 171   return last_bd;
 172 }
 173
 174 void
 175 exitStorage (void)
 176 {
 177   lnat allocated;
 178   bdescr *bd;
 179
 180   /* Return code ignored for now */
 181   /* ToDo: allocation figure is slightly wrong (see also GarbageCollect()) */
 182   allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
 183   for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
 184     allocated -= BLOCK_SIZE_W;
 185   }
 186   stat_exit(allocated);
 187 }
 188
 189 void
 190 recordMutable(StgMutClosure *p)
 191 {
 192   bdescr *bd;
 193
 194   ASSERT(closure_MUTABLE(p));
 195
 196   bd = Bdescr((P_)p);
 197
 198   /* no need to bother in generation 0 */
 199   if (bd->gen == g0) {
 200     return;
 201   }
 202
 203   if (p->mut_link == NULL) {
 204     p->mut_link = bd->gen->mut_list;
 205     bd->gen->mut_list = p;
 206   }
 207 }
 208
 209 void
 210 newCAF(StgClosure* caf)
 211 {
 212   /* Put this CAF on the mutable list for the old generation.
 213    * This is a HACK - the IND_STATIC closure doesn't really have
 214    * a mut_link field, but we pretend it has - in fact we re-use
 215    * the STATIC_LINK field for the time being, because when we
 216    * come to do a major GC we won't need the mut_link field
 217    * any more and can use it as a STATIC_LINK.
 218    */
 219   ((StgMutClosure *)caf)->mut_link = oldest_gen->mut_list;
 220   oldest_gen->mut_list = (StgMutClosure *)caf;
 221
 222 #ifdef DEBUG
 223   {
 224     const StgInfoTable *info;
 225
 226     info = get_itbl(caf);
 227     ASSERT(info->type == IND_STATIC);
 228     STATIC_LINK2(info,caf) = caf_list;
 229     caf_list = caf;
 230   }
 231 #endif
 232 }
 233
 234 /* -----------------------------------------------------------------------------
 235    The allocate() interface
 236
 237    allocate(n) always succeeds, and returns a chunk of memory n words
 238    long.  n can be larger than the size of a block if necessary, in
 239    which case a contiguous block group will be allocated.
 240    -------------------------------------------------------------------------- */
 241
 242 StgPtr
 243 allocate(nat n)
 244 {
 245   bdescr *bd;
 246   StgPtr p;
 247
 248   TICK_ALLOC_HEAP(n);
 249   CCS_ALLOC(CCCS,n);
 250
 251   /* big allocation (>LARGE_OBJECT_THRESHOLD) */
 252   /* ToDo: allocate directly into generation 1 */
 253   if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
 254     nat req_blocks =  (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
 255     bd = allocGroup(req_blocks);
 256     dbl_link_onto(bd, &g0s0->large_objects);
 257     bd->gen  = g0;
 258     bd->step = g0s0;
 259     bd->evacuated = 0;
 260     bd->free = bd->start;
 261     /* don't add these blocks to alloc_blocks, since we're assuming
 262      * that large objects are likely to remain live for quite a while
 263      * (eg. running threads), so garbage collecting early won't make
 264      * much difference.
 265      */
 266     return bd->start;
 267
 268   /* small allocation (<LARGE_OBJECT_THRESHOLD) */
 269   } else if (small_alloc_list == NULL || alloc_Hp + n > alloc_HpLim) {
 270     if (small_alloc_list) {
 271       small_alloc_list->free = alloc_Hp;
 272     }
 273     bd = allocBlock();
 274     bd->link = small_alloc_list;
 275     small_alloc_list = bd;
 276     bd->gen = g0;
 277     bd->step = g0s0;
 278     bd->evacuated = 0;
 279     alloc_Hp = bd->start;
 280     alloc_HpLim = bd->start + BLOCK_SIZE_W;
 281     alloc_blocks++;
 282   }
 283
 284   p = alloc_Hp;
 285   alloc_Hp += n;
 286   return p;
 287 }
 288
 289 lnat allocated_bytes(void)
 290 {
 291   return (alloc_blocks * BLOCK_SIZE_W - (alloc_HpLim - alloc_Hp));
 292 }
 293
 294 /* -----------------------------------------------------------------------------
 295    Allocation functions for GMP.
 296
 297    These all use the allocate() interface - we can't have any garbage
 298    collection going on during a gmp operation, so we use allocate()
 299    which always succeeds.  The gmp operations which might need to
 300    allocate will ask the storage manager (via doYouWantToGC()) whether
 301    a garbage collection is required, in case we get into a loop doing
 302    only allocate() style allocation.
 303    -------------------------------------------------------------------------- */
 304
 305 static void *
 306 stgAllocForGMP (size_t size_in_bytes)
 307 {
 308   StgArrWords* arr;
 309   nat data_size_in_words, total_size_in_words;
 310
 311   /* should be a multiple of sizeof(StgWord) (whole no. of limbs) */
 312   ASSERT(size_in_bytes % sizeof(W_) == 0);
 313
 314   data_size_in_words  = size_in_bytes / sizeof(W_);
 315   total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
 316
 317   /* allocate and fill it in. */
 318   arr = (StgArrWords *)allocate(total_size_in_words);
 319   SET_ARR_HDR(arr, &ARR_WORDS_info, CCCS, data_size_in_words);
 320
 321   /* and return a ptr to the goods inside the array */
 322   return(BYTE_ARR_CTS(arr));
 323 }
 324
 325 static void *
 326 stgReallocForGMP (void *ptr, size_t old_size, size_t new_size)
 327 {
 328     void *new_stuff_ptr = stgAllocForGMP(new_size);
 329     nat i = 0;
 330     char *p = (char *) ptr;
 331     char *q = (char *) new_stuff_ptr;
 332
 333     for (; i < old_size; i++, p++, q++) {
 334         *q = *p;
 335     }
 336
 337     return(new_stuff_ptr);
 338 }
 339
 340 static void
 341 stgDeallocForGMP (void *ptr STG_UNUSED,
 342                   size_t size STG_UNUSED)
 343 {
 344     /* easy for us: the garbage collector does the dealloc'n */
 345 }
 346
 347 /* -----------------------------------------------------------------------------
 348    Debugging
 349
 350    memInventory() checks for memory leaks by counting up all the
 351    blocks we know about and comparing that to the number of blocks
 352    allegedly floating around in the system.
 353    -------------------------------------------------------------------------- */
 354
 355 #ifdef DEBUG
 356
 357 extern void
 358 memInventory(void)
 359 {
 360   nat g, s;
 361   step *step;
 362   bdescr *bd;
 363   lnat total_blocks = 0, free_blocks = 0;
 364
 365   /* count the blocks we current have */
 366
 367   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 368     for (s = 0; s < generations[g].n_steps; s++) {
 369       step = &generations[g].steps[s];
 370       total_blocks += step->n_blocks;
 371       if (RtsFlags.GcFlags.generations == 1) {
 372         /* two-space collector has a to-space too :-) */
 373         total_blocks += g0s0->to_blocks;
 374       }
 375       for (bd = step->large_objects; bd; bd = bd->link) {
 376         total_blocks += bd->blocks;
 377         /* hack for megablock groups: they have an extra block or two in
 378            the second and subsequent megablocks where the block
 379            descriptors would normally go.
 380         */
 381         if (bd->blocks > BLOCKS_PER_MBLOCK) {
 382           total_blocks -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
 383                           * bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE);
 384         }
 385       }
 386     }
 387   }
 388
 389   /* any blocks held by allocate() */
 390   for (bd = small_alloc_list; bd; bd = bd->link) {
 391     total_blocks += bd->blocks;
 392   }
 393   for (bd = large_alloc_list; bd; bd = bd->link) {
 394     total_blocks += bd->blocks;
 395   }
 396
 397   /* count the blocks on the free list */
 398   free_blocks = countFreeList();
 399
 400   ASSERT(total_blocks + free_blocks == mblocks_allocated * BLOCKS_PER_MBLOCK);
 401
 402 #if 0
 403   if (total_blocks + free_blocks != mblocks_allocated *
 404       BLOCKS_PER_MBLOCK) {
 405     fprintf(stderr, "Blocks: %ld live + %ld free  = %ld total (%ld around)\n",
 406             total_blocks, free_blocks, total_blocks + free_blocks,
 407             mblocks_allocated * BLOCKS_PER_MBLOCK);
 408   }
 409 #endif
 410 }
 411
 412 #endif