ghc/rts/Storage.c

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