1 /* -----------------------------------------------------------------------------
2 * $Id: Storage.c,v 1.18 1999/09/15 13:45:20 simonmar Exp $
4 * (c) The GHC Team, 1998-1999
6 * Storage manager front end
8 * ---------------------------------------------------------------------------*/
15 #include "BlockAlloc.h"
22 #include "StoragePriv.h"
24 bdescr *current_nursery; /* next available nursery block, or NULL */
25 nat nursery_blocks; /* number of blocks in the nursery */
27 StgClosure *caf_list = NULL;
29 bdescr *small_alloc_list; /* allocate()d small objects */
30 bdescr *large_alloc_list; /* allocate()d large objects */
31 nat alloc_blocks; /* number of allocate()d blocks since GC */
32 nat alloc_blocks_lim; /* approximate limit on alloc_blocks */
34 StgPtr alloc_Hp = NULL; /* next free byte in small_alloc_list */
35 StgPtr alloc_HpLim = NULL; /* end of block at small_alloc_list */
37 generation *generations; /* all the generations */
38 generation *g0; /* generation 0, for convenience */
39 generation *oldest_gen; /* oldest generation, for convenience */
40 step *g0s0; /* generation 0, step 0, for convenience */
45 static void *stgAllocForGMP (size_t size_in_bytes);
46 static void *stgReallocForGMP (void *ptr, size_t old_size, size_t new_size);
47 static void stgDeallocForGMP (void *ptr, size_t size);
56 /* If we're doing heap profiling, we want a two-space heap with a
57 * fixed-size allocation area so that we get roughly even-spaced
60 #if defined(PROFILING) || defined(DEBUG)
61 if (RtsFlags.ProfFlags.doHeapProfile) {
62 RtsFlags.GcFlags.generations = 1;
63 RtsFlags.GcFlags.steps = 1;
64 RtsFlags.GcFlags.oldGenFactor = 0;
65 RtsFlags.GcFlags.heapSizeSuggestion = 0;
69 if (RtsFlags.GcFlags.heapSizeSuggestion >
70 RtsFlags.GcFlags.maxHeapSize) {
71 RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion;
76 /* allocate generation info array */
77 generations = (generation *)stgMallocBytes(RtsFlags.GcFlags.generations
78 * sizeof(struct _generation),
81 /* Initialise all generations */
82 for(g = 0; g < RtsFlags.GcFlags.generations; g++) {
83 gen = &generations[g];
85 gen->mut_list = END_MUT_LIST;
86 gen->mut_once_list = END_MUT_LIST;
88 gen->failed_promotions = 0;
92 /* A couple of convenience pointers */
94 oldest_gen = &generations[RtsFlags.GcFlags.generations-1];
96 /* Allocate step structures in each generation */
97 if (RtsFlags.GcFlags.generations > 1) {
98 /* Only for multiple-generations */
100 /* Oldest generation: one step */
101 oldest_gen->n_steps = 1;
103 stgMallocBytes(1 * sizeof(struct _step), "initStorage: last step");
105 /* set up all except the oldest generation with 2 steps */
106 for(g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
107 generations[g].n_steps = RtsFlags.GcFlags.steps;
108 generations[g].steps =
109 stgMallocBytes (RtsFlags.GcFlags.steps * sizeof(struct _step),
110 "initStorage: steps");
114 /* single generation, i.e. a two-space collector */
116 g0->steps = stgMallocBytes (sizeof(struct _step), "initStorage: steps");
119 /* Initialise all steps */
120 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
121 for (s = 0; s < generations[g].n_steps; s++) {
122 step = &generations[g].steps[s];
126 step->gen = &generations[g];
131 step->scan_bd = NULL;
132 step->large_objects = NULL;
133 step->new_large_objects = NULL;
134 step->scavenged_large_objects = NULL;
138 /* Set up the destination pointers in each younger gen. step */
139 for (g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
140 for (s = 0; s < generations[g].n_steps-1; s++) {
141 generations[g].steps[s].to = &generations[g].steps[s+1];
143 generations[g].steps[s].to = &generations[g+1].steps[0];
146 /* The oldest generation has one step and its destination is the
148 oldest_gen->steps[0].to = &oldest_gen->steps[0];
150 /* generation 0 is special: that's the nursery */
151 generations[0].max_blocks = 0;
153 /* G0S0: the allocation area. Policy: keep the allocation area
154 * small to begin with, even if we have a large suggested heap
155 * size. Reason: we're going to do a major collection first, and we
156 * don't want it to be a big one. This vague idea is borne out by
157 * rigorous experimental evidence.
159 step = &generations[0].steps[0];
161 nursery_blocks = RtsFlags.GcFlags.minAllocAreaSize;
162 step->blocks = allocNursery(NULL, nursery_blocks);
163 step->n_blocks = nursery_blocks;
164 current_nursery = step->blocks;
165 g0s0->to_space = NULL;
166 /* hp, hpLim, hp_bd, to_space etc. aren't used in G0S0 */
168 weak_ptr_list = NULL;
171 /* initialise the allocate() interface */
172 small_alloc_list = NULL;
173 large_alloc_list = NULL;
175 alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
178 /* Tell GNU multi-precision pkg about our custom alloc functions */
179 mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);
182 IF_DEBUG(gc, stat_describe_gens());
186 allocNursery (bdescr *last_bd, nat blocks)
191 /* Allocate a nursery */
192 for (i=0; i < blocks; i++) {
198 bd->free = bd->start;
205 resizeNursery ( nat blocks )
209 if (nursery_blocks == blocks) {
210 ASSERT(g0s0->n_blocks == blocks);
214 else if (nursery_blocks < blocks) {
215 IF_DEBUG(gc, fprintf(stderr, "Increasing size of nursery to %d blocks\n",
217 g0s0->blocks = allocNursery(g0s0->blocks, blocks-nursery_blocks);
223 IF_DEBUG(gc, fprintf(stderr, "Decreasing size of nursery to %d blocks\n",
225 for (bd = g0s0->blocks; nursery_blocks > blocks; nursery_blocks--) {
233 g0s0->n_blocks = nursery_blocks = blocks;
242 /* Return code ignored for now */
243 /* ToDo: allocation figure is slightly wrong (see also GarbageCollect()) */
244 allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
245 for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
246 allocated -= BLOCK_SIZE_W;
248 stat_exit(allocated);
252 newCAF(StgClosure* caf)
254 /* Put this CAF on the mutable list for the old generation.
255 * This is a HACK - the IND_STATIC closure doesn't really have
256 * a mut_link field, but we pretend it has - in fact we re-use
257 * the STATIC_LINK field for the time being, because when we
258 * come to do a major GC we won't need the mut_link field
259 * any more and can use it as a STATIC_LINK.
261 ((StgMutClosure *)caf)->mut_link = oldest_gen->mut_once_list;
262 oldest_gen->mut_once_list = (StgMutClosure *)caf;
266 const StgInfoTable *info;
268 info = get_itbl(caf);
269 ASSERT(info->type == IND_STATIC);
271 STATIC_LINK2(info,caf) = caf_list;
278 /* -----------------------------------------------------------------------------
279 The allocate() interface
281 allocate(n) always succeeds, and returns a chunk of memory n words
282 long. n can be larger than the size of a block if necessary, in
283 which case a contiguous block group will be allocated.
284 -------------------------------------------------------------------------- */
295 /* big allocation (>LARGE_OBJECT_THRESHOLD) */
296 /* ToDo: allocate directly into generation 1 */
297 if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
298 nat req_blocks = (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
299 bd = allocGroup(req_blocks);
300 dbl_link_onto(bd, &g0s0->large_objects);
304 bd->free = bd->start;
305 /* don't add these blocks to alloc_blocks, since we're assuming
306 * that large objects are likely to remain live for quite a while
307 * (eg. running threads), so garbage collecting early won't make
312 /* small allocation (<LARGE_OBJECT_THRESHOLD) */
313 } else if (small_alloc_list == NULL || alloc_Hp + n > alloc_HpLim) {
314 if (small_alloc_list) {
315 small_alloc_list->free = alloc_Hp;
318 bd->link = small_alloc_list;
319 small_alloc_list = bd;
323 alloc_Hp = bd->start;
324 alloc_HpLim = bd->start + BLOCK_SIZE_W;
333 lnat allocated_bytes(void)
335 return (alloc_blocks * BLOCK_SIZE_W - (alloc_HpLim - alloc_Hp));
338 /* -----------------------------------------------------------------------------
339 Allocation functions for GMP.
341 These all use the allocate() interface - we can't have any garbage
342 collection going on during a gmp operation, so we use allocate()
343 which always succeeds. The gmp operations which might need to
344 allocate will ask the storage manager (via doYouWantToGC()) whether
345 a garbage collection is required, in case we get into a loop doing
346 only allocate() style allocation.
347 -------------------------------------------------------------------------- */
350 stgAllocForGMP (size_t size_in_bytes)
353 nat data_size_in_words, total_size_in_words;
355 /* should be a multiple of sizeof(StgWord) (whole no. of limbs) */
356 ASSERT(size_in_bytes % sizeof(W_) == 0);
358 data_size_in_words = size_in_bytes / sizeof(W_);
359 total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
361 /* allocate and fill it in. */
362 arr = (StgArrWords *)allocate(total_size_in_words);
363 SET_ARR_HDR(arr, &ARR_WORDS_info, CCCS, data_size_in_words);
365 /* and return a ptr to the goods inside the array */
366 return(BYTE_ARR_CTS(arr));
370 stgReallocForGMP (void *ptr, size_t old_size, size_t new_size)
372 void *new_stuff_ptr = stgAllocForGMP(new_size);
374 char *p = (char *) ptr;
375 char *q = (char *) new_stuff_ptr;
377 for (; i < old_size; i++, p++, q++) {
381 return(new_stuff_ptr);
385 stgDeallocForGMP (void *ptr STG_UNUSED,
386 size_t size STG_UNUSED)
388 /* easy for us: the garbage collector does the dealloc'n */
391 /* -----------------------------------------------------------------------------
393 -------------------------------------------------------------------------- */
395 /* Approximate the amount of live data in the heap. To be called just
396 * after garbage collection (see GarbageCollect()).
405 if (RtsFlags.GcFlags.generations == 1) {
406 live = (g0s0->to_blocks - 1) * BLOCK_SIZE_W +
407 ((lnat)g0s0->hp_bd->free - (lnat)g0s0->hp_bd->start) / sizeof(W_);
411 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
412 for (s = 0; s < generations[g].n_steps; s++) {
413 /* approximate amount of live data (doesn't take into account slop
414 * at end of each block).
416 if (g == 0 && s == 0) {
419 step = &generations[g].steps[s];
420 live += (step->n_blocks - 1) * BLOCK_SIZE_W +
421 ((lnat)step->hp_bd->free - (lnat)step->hp_bd->start) / sizeof(W_);
427 /* Approximate the number of blocks that will be needed at the next
428 * garbage collection.
430 * Assume: all data currently live will remain live. Steps that will
431 * be collected next time will therefore need twice as many blocks
432 * since all the data will be copied.
441 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
442 for (s = 0; s < generations[g].n_steps; s++) {
443 if (g == 0 && s == 0) { continue; }
444 step = &generations[g].steps[s];
445 if (generations[g].steps[0].n_blocks > generations[g].max_blocks) {
446 needed += 2 * step->n_blocks;
448 needed += step->n_blocks;
455 /* -----------------------------------------------------------------------------
458 memInventory() checks for memory leaks by counting up all the
459 blocks we know about and comparing that to the number of blocks
460 allegedly floating around in the system.
461 -------------------------------------------------------------------------- */
471 lnat total_blocks = 0, free_blocks = 0;
473 /* count the blocks we current have */
475 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
476 for (s = 0; s < generations[g].n_steps; s++) {
477 step = &generations[g].steps[s];
478 total_blocks += step->n_blocks;
479 if (RtsFlags.GcFlags.generations == 1) {
480 /* two-space collector has a to-space too :-) */
481 total_blocks += g0s0->to_blocks;
483 for (bd = step->large_objects; bd; bd = bd->link) {
484 total_blocks += bd->blocks;
485 /* hack for megablock groups: they have an extra block or two in
486 the second and subsequent megablocks where the block
487 descriptors would normally go.
489 if (bd->blocks > BLOCKS_PER_MBLOCK) {
490 total_blocks -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
491 * bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE);
497 /* any blocks held by allocate() */
498 for (bd = small_alloc_list; bd; bd = bd->link) {
499 total_blocks += bd->blocks;
501 for (bd = large_alloc_list; bd; bd = bd->link) {
502 total_blocks += bd->blocks;
505 /* count the blocks on the free list */
506 free_blocks = countFreeList();
508 ASSERT(total_blocks + free_blocks == mblocks_allocated * BLOCKS_PER_MBLOCK);
511 if (total_blocks + free_blocks != mblocks_allocated *
513 fprintf(stderr, "Blocks: %ld live + %ld free = %ld total (%ld around)\n",
514 total_blocks, free_blocks, total_blocks + free_blocks,
515 mblocks_allocated * BLOCKS_PER_MBLOCK);
520 /* Full heap sanity check. */
527 if (RtsFlags.GcFlags.generations == 1) {
528 checkHeap(g0s0->to_space, NULL);
529 checkChain(g0s0->large_objects);
532 for (g = 0; g <= N; g++) {
533 for (s = 0; s < generations[g].n_steps; s++) {
534 if (g == 0 && s == 0) { continue; }
535 checkHeap(generations[g].steps[s].blocks, NULL);
538 for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
539 for (s = 0; s < generations[g].n_steps; s++) {
540 checkHeap(generations[g].steps[s].blocks,
541 generations[g].steps[s].blocks->start);
542 checkChain(generations[g].steps[s].large_objects);
545 checkFreeListSanity();