Storage.c 30.5 KB
Newer Older
1
/* -----------------------------------------------------------------------------
2
 *
3
 * (c) The GHC Team, 1998-2004
4
5
6
7
8
 *
 * Storage manager front end
 *
 * ---------------------------------------------------------------------------*/

9
#include "PosixSource.h"
10
11
12
13
14
15
#include "Rts.h"
#include "RtsUtils.h"
#include "RtsFlags.h"
#include "Stats.h"
#include "Hooks.h"
#include "BlockAlloc.h"
16
#include "MBlock.h"
17
#include "Weak.h"
18
#include "Sanity.h"
19
#include "Arena.h"
20
21
#include "OSThreads.h"
#include "Capability.h"
22
#include "Storage.h"
23
#include "Schedule.h"
24
25
#include "RetainerProfile.h"	// for counting memory blocks (memInventory)

26
27
28
#include <stdlib.h>
#include <string.h>

29
30
31
/* 
 * All these globals require sm_mutex to access in SMP mode.
 */
32
StgClosure    *caf_list         = NULL;
33
34
StgClosure    *revertible_caf_list = NULL;
rtsBool       keepCAFs;
35
36

bdescr *small_alloc_list;	/* allocate()d small objects */
37
bdescr *pinned_object_block;    /* allocate pinned objects into this block */
38
39
40
41
42
43
nat alloc_blocks;		/* number of allocate()d blocks since GC */
nat alloc_blocks_lim;		/* approximate limit on alloc_blocks */

StgPtr alloc_Hp    = NULL;	/* next free byte in small_alloc_list */
StgPtr alloc_HpLim = NULL;	/* end of block at small_alloc_list   */

44
45
46
47
generation *generations = NULL;	/* all the generations */
generation *g0		= NULL; /* generation 0, for convenience */
generation *oldest_gen  = NULL; /* oldest generation, for convenience */
step *g0s0 		= NULL; /* generation 0, step 0, for convenience */
48

49
ullong total_allocated = 0;	/* total memory allocated during run */
50

51
52
53
nat n_nurseries         = 0;    /* == RtsFlags.ParFlags.nNodes, convenience */
step *nurseries         = NULL; /* array of nurseries, >1 only if SMP */

54
55
56
57
58
/*
 * Storage manager mutex:  protects all the above state from
 * simultaneous access by two STG threads.
 */
#ifdef SMP
59
Mutex sm_mutex;
60
61
#endif

62
63
64
65
66
67
68
/*
 * Forward references
 */
static void *stgAllocForGMP   (size_t size_in_bytes);
static void *stgReallocForGMP (void *ptr, size_t old_size, size_t new_size);
static void  stgDeallocForGMP (void *ptr, size_t size);

69
70
71
72
73
74
static void
initStep (step *stp, int g, int s)
{
    stp->no = s;
    stp->blocks = NULL;
    stp->n_blocks = 0;
75
76
    stp->old_blocks = NULL;
    stp->n_old_blocks = 0;
77
78
79
80
81
    stp->gen = &generations[g];
    stp->gen_no = g;
    stp->hp = NULL;
    stp->hpLim = NULL;
    stp->hp_bd = NULL;
82
83
    stp->scavd_hp = NULL;
    stp->scavd_hpLim = NULL;
84
85
86
87
88
89
90
91
92
93
94
    stp->scan = NULL;
    stp->scan_bd = NULL;
    stp->large_objects = NULL;
    stp->n_large_blocks = 0;
    stp->new_large_objects = NULL;
    stp->scavenged_large_objects = NULL;
    stp->n_scavenged_large_blocks = 0;
    stp->is_compacted = 0;
    stp->bitmap = NULL;
}

95
void
96
initStorage( void )
97
{
98
  nat g, s;
99
  generation *gen;
100

101
102
103
104
105
  if (generations != NULL) {
      // multi-init protection
      return;
  }

sof's avatar
sof committed
106
107
108
109
110
111
112
  /* Sanity check to make sure the LOOKS_LIKE_ macros appear to be
   * doing something reasonable.
   */
  ASSERT(LOOKS_LIKE_INFO_PTR(&stg_BLACKHOLE_info));
  ASSERT(LOOKS_LIKE_CLOSURE_PTR(&stg_dummy_ret_closure));
  ASSERT(!HEAP_ALLOCED(&stg_dummy_ret_closure));
  
113
114
  if (RtsFlags.GcFlags.maxHeapSize != 0 &&
      RtsFlags.GcFlags.heapSizeSuggestion > 
115
      RtsFlags.GcFlags.maxHeapSize) {
116
    RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion;
117
118
  }

119
120
121
  if (RtsFlags.GcFlags.maxHeapSize != 0 &&
      RtsFlags.GcFlags.minAllocAreaSize > 
      RtsFlags.GcFlags.maxHeapSize) {
122
      errorBelch("maximum heap size (-M) is smaller than minimum alloc area size (-A)");
123
124
125
      exit(1);
  }

126
127
  initBlockAllocator();
  
sof's avatar
sof committed
128
#if defined(SMP)
sof's avatar
sof committed
129
  initMutex(&sm_mutex);
sof's avatar
sof committed
130
131
#endif

132
133
  ACQUIRE_SM_LOCK;

134
135
  /* allocate generation info array */
  generations = (generation *)stgMallocBytes(RtsFlags.GcFlags.generations 
136
					     * sizeof(struct generation_),
137
138
					     "initStorage: gens");

139
  /* Initialise all generations */
140
  for(g = 0; g < RtsFlags.GcFlags.generations; g++) {
141
142
    gen = &generations[g];
    gen->no = g;
143
    gen->mut_list = allocBlock();
144
145
    gen->collections = 0;
    gen->failed_promotions = 0;
146
    gen->max_blocks = 0;
147
148
  }

149
150
151
152
153
154
155
156
157
158
159
  /* A couple of convenience pointers */
  g0 = &generations[0];
  oldest_gen = &generations[RtsFlags.GcFlags.generations-1];

  /* Allocate step structures in each generation */
  if (RtsFlags.GcFlags.generations > 1) {
    /* Only for multiple-generations */

    /* Oldest generation: one step */
    oldest_gen->n_steps = 1;
    oldest_gen->steps = 
160
      stgMallocBytes(1 * sizeof(struct step_), "initStorage: last step");
161
162
163

    /* set up all except the oldest generation with 2 steps */
    for(g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
164
165
      generations[g].n_steps = RtsFlags.GcFlags.steps;
      generations[g].steps  = 
166
	stgMallocBytes (RtsFlags.GcFlags.steps * sizeof(struct step_),
167
			"initStorage: steps");
168
169
170
171
172
    }
    
  } else {
    /* single generation, i.e. a two-space collector */
    g0->n_steps = 1;
173
    g0->steps = stgMallocBytes (sizeof(struct step_), "initStorage: steps");
174
175
  }

176
#ifdef SMP
177
  n_nurseries = n_capabilities;
178
179
180
181
182
183
184
  nurseries = stgMallocBytes (n_nurseries * sizeof(struct step_),
			      "initStorage: nurseries");
#else
  n_nurseries = 1;
  nurseries = g0->steps; // just share nurseries[0] with g0s0
#endif  

185
186
  /* Initialise all steps */
  for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
187
    for (s = 0; s < generations[g].n_steps; s++) {
188
	initStep(&generations[g].steps[s], g, s);
189
190
191
    }
  }
  
192
193
194
195
196
197
#ifdef SMP
  for (s = 0; s < n_nurseries; s++) {
      initStep(&nurseries[s], 0, s);
  }
#endif
  
198
199
  /* Set up the destination pointers in each younger gen. step */
  for (g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
200
201
    for (s = 0; s < generations[g].n_steps-1; s++) {
      generations[g].steps[s].to = &generations[g].steps[s+1];
202
    }
203
    generations[g].steps[s].to = &generations[g+1].steps[0];
204
  }
205
  oldest_gen->steps[0].to = &oldest_gen->steps[0];
206
  
207
208
209
210
211
212
213
#ifdef SMP
  for (s = 0; s < n_nurseries; s++) {
      nurseries[s].to = generations[0].steps[0].to;
  }
#endif
  
  /* The oldest generation has one step. */
214
  if (RtsFlags.GcFlags.compact) {
215
      if (RtsFlags.GcFlags.generations == 1) {
216
	  errorBelch("WARNING: compaction is incompatible with -G1; disabled");
217
218
219
      } else {
	  oldest_gen->steps[0].is_compacted = 1;
      }
220
  }
221
222
223
224

#ifdef SMP
  if (RtsFlags.GcFlags.generations == 1) {
      errorBelch("-G1 is incompatible with SMP");
225
      stg_exit(EXIT_FAILURE);
226
227
  }
#endif
228
229
230
231

  /* generation 0 is special: that's the nursery */
  generations[0].max_blocks = 0;

232
233
234
235
236
237
  /* G0S0: the allocation area.  Policy: keep the allocation area
   * small to begin with, even if we have a large suggested heap
   * size.  Reason: we're going to do a major collection first, and we
   * don't want it to be a big one.  This vague idea is borne out by 
   * rigorous experimental evidence.
   */
238
239
240
  g0s0 = &generations[0].steps[0];

  allocNurseries();
241
242
243

  weak_ptr_list = NULL;
  caf_list = NULL;
244
  revertible_caf_list = NULL;
245
246
247
248
249
250
251
252
   
  /* initialise the allocate() interface */
  small_alloc_list = NULL;
  alloc_blocks = 0;
  alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;

  /* Tell GNU multi-precision pkg about our custom alloc functions */
  mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);
253

254
  IF_DEBUG(gc, statDescribeGens());
255
256

  RELEASE_SM_LOCK;
257
258
}

259
260
261
void
exitStorage (void)
{
262
    stat_exit(calcAllocated());
263
264
}

265
266
/* -----------------------------------------------------------------------------
   CAF management.
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303

   The entry code for every CAF does the following:
     
      - builds a CAF_BLACKHOLE in the heap
      - pushes an update frame pointing to the CAF_BLACKHOLE
      - invokes UPD_CAF(), which:
          - calls newCaf, below
	  - updates the CAF with a static indirection to the CAF_BLACKHOLE
      
   Why do we build a BLACKHOLE in the heap rather than just updating
   the thunk directly?  It's so that we only need one kind of update
   frame - otherwise we'd need a static version of the update frame too.

   newCaf() does the following:
       
      - it puts the CAF on the oldest generation's mut-once list.
        This is so that we can treat the CAF as a root when collecting
	younger generations.

   For GHCI, we have additional requirements when dealing with CAFs:

      - we must *retain* all dynamically-loaded CAFs ever entered,
        just in case we need them again.
      - we must be able to *revert* CAFs that have been evaluated, to
        their pre-evaluated form.

      To do this, we use an additional CAF list.  When newCaf() is
      called on a dynamically-loaded CAF, we add it to the CAF list
      instead of the old-generation mutable list, and save away its
      old info pointer (in caf->saved_info) for later reversion.

      To revert all the CAFs, we traverse the CAF list and reset the
      info pointer to caf->saved_info, then throw away the CAF list.
      (see GC.c:revertCAFs()).

      -- SDM 29/1/01

304
305
   -------------------------------------------------------------------------- */

306
307
308
void
newCAF(StgClosure* caf)
{
sof's avatar
sof committed
309
  ACQUIRE_SM_LOCK;
310

311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
  if(keepCAFs)
  {
    // HACK:
    // If we are in GHCi _and_ we are using dynamic libraries,
    // then we can't redirect newCAF calls to newDynCAF (see below),
    // so we make newCAF behave almost like newDynCAF.
    // The dynamic libraries might be used by both the interpreted
    // program and GHCi itself, so they must not be reverted.
    // This also means that in GHCi with dynamic libraries, CAFs are not
    // garbage collected. If this turns out to be a problem, we could
    // do another hack here and do an address range test on caf to figure
    // out whether it is from a dynamic library.
    ((StgIndStatic *)caf)->saved_info  = (StgInfoTable *)caf->header.info;
    ((StgIndStatic *)caf)->static_link = caf_list;
    caf_list = caf;
  }
  else
  {
    /* Put this CAF on the mutable list for the old generation.
    * This is a HACK - the IND_STATIC closure doesn't really have
    * a mut_link field, but we pretend it has - in fact we re-use
    * the STATIC_LINK field for the time being, because when we
    * come to do a major GC we won't need the mut_link field
    * any more and can use it as a STATIC_LINK.
    */
    ((StgIndStatic *)caf)->saved_info = NULL;
    recordMutableGen(caf, oldest_gen);
  }
  
sof's avatar
sof committed
340
  RELEASE_SM_LOCK;
341
342
343
344

#ifdef PAR
  /* If we are PAR or DIST then  we never forget a CAF */
  { globalAddr *newGA;
345
    //debugBelch("<##> Globalising CAF %08x %s",caf,info_type(caf));
346
347
348
    newGA=makeGlobal(caf,rtsTrue); /*given full weight*/
    ASSERT(newGA);
  } 
sof's avatar
sof committed
349
#endif /* PAR */
350
351
}

352
353
354
355
// An alternate version of newCaf which is used for dynamically loaded
// object code in GHCi.  In this case we want to retain *all* CAFs in
// the object code, because they might be demanded at any time from an
// expression evaluated on the command line.
356
357
// Also, GHCi might want to revert CAFs, so we add these to the
// revertible_caf_list.
358
359
360
361
362
363
364
365
366
//
// The linker hackily arranges that references to newCaf from dynamic
// code end up pointing to newDynCAF.
void
newDynCAF(StgClosure *caf)
{
    ACQUIRE_SM_LOCK;

    ((StgIndStatic *)caf)->saved_info  = (StgInfoTable *)caf->header.info;
367
368
    ((StgIndStatic *)caf)->static_link = revertible_caf_list;
    revertible_caf_list = caf;
369
370
371
372

    RELEASE_SM_LOCK;
}

373
374
375
376
/* -----------------------------------------------------------------------------
   Nursery management.
   -------------------------------------------------------------------------- */

377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
static bdescr *
allocNursery (step *stp, bdescr *tail, nat blocks)
{
    bdescr *bd;
    nat i;

    // Allocate a nursery: we allocate fresh blocks one at a time and
    // cons them on to the front of the list, not forgetting to update
    // the back pointer on the tail of the list to point to the new block.
    for (i=0; i < blocks; i++) {
	// @LDV profiling
	/*
	  processNursery() in LdvProfile.c assumes that every block group in
	  the nursery contains only a single block. So, if a block group is
	  given multiple blocks, change processNursery() accordingly.
	*/
	bd = allocBlock();
	bd->link = tail;
	// double-link the nursery: we might need to insert blocks
	if (tail != NULL) {
	    tail->u.back = bd;
	}
	bd->step = stp;
	bd->gen_no = 0;
	bd->flags = 0;
	bd->free = bd->start;
	tail = bd;
    }
    tail->u.back = NULL;
    return tail;
}

static void
assignNurseriesToCapabilities (void)
{
412
#ifdef SMP
413
    nat i;
sof's avatar
sof committed
414

415
416
417
    for (i = 0; i < n_nurseries; i++) {
	capabilities[i].r.rNursery        = &nurseries[i];
	capabilities[i].r.rCurrentNursery = nurseries[i].blocks;
418
	capabilities[i].r.rCurrentAlloc   = NULL;
419
    }
420
#else /* SMP */
421
422
    MainCapability.r.rNursery        = &nurseries[0];
    MainCapability.r.rCurrentNursery = nurseries[0].blocks;
423
    MainCapability.r.rCurrentAlloc   = NULL;
424
425
#endif
}
426
427
428
429
430
431
432
433
434
435
436

void
allocNurseries( void )
{ 
    nat i;

    for (i = 0; i < n_nurseries; i++) {
	nurseries[i].blocks = 
	    allocNursery(&nurseries[i], NULL, 
			 RtsFlags.GcFlags.minAllocAreaSize);
	nurseries[i].n_blocks    = RtsFlags.GcFlags.minAllocAreaSize;
437
438
	nurseries[i].old_blocks   = NULL;
	nurseries[i].n_old_blocks = 0;
439
440
441
442
	/* hp, hpLim, hp_bd, to_space etc. aren't used in the nursery */
    }
    assignNurseriesToCapabilities();
}
443
444
445
446
      
void
resetNurseries( void )
{
447
448
449
    nat i;
    bdescr *bd;
    step *stp;
450

451
452
453
454
455
456
457
458
    for (i = 0; i < n_nurseries; i++) {
	stp = &nurseries[i];
	for (bd = stp->blocks; bd; bd = bd->link) {
	    bd->free = bd->start;
	    ASSERT(bd->gen_no == 0);
	    ASSERT(bd->step == stp);
	    IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
	}
459
    }
460
    assignNurseriesToCapabilities();
461
462
}

463
464
lnat
countNurseryBlocks (void)
465
{
466
467
    nat i;
    lnat blocks = 0;
468

469
470
    for (i = 0; i < n_nurseries; i++) {
	blocks += nurseries[i].n_blocks;
471
    }
472
    return blocks;
473
474
}

475
476
static void
resizeNursery ( step *stp, nat blocks )
477
478
{
  bdescr *bd;
479
  nat nursery_blocks;
480

481
482
  nursery_blocks = stp->n_blocks;
  if (nursery_blocks == blocks) return;
483

484
  if (nursery_blocks < blocks) {
485
    IF_DEBUG(gc, debugBelch("Increasing size of nursery to %d blocks\n", 
486
			 blocks));
487
    stp->blocks = allocNursery(stp, stp->blocks, blocks-nursery_blocks);
488
489
490
491
  } 
  else {
    bdescr *next_bd;
    
492
    IF_DEBUG(gc, debugBelch("Decreasing size of nursery to %d blocks\n", 
493
			 blocks));
494

495
    bd = stp->blocks;
496
497
498
499
500
501
    while (nursery_blocks > blocks) {
	next_bd = bd->link;
	next_bd->u.back = NULL;
	nursery_blocks -= bd->blocks; // might be a large block
	freeGroup(bd);
	bd = next_bd;
502
    }
503
    stp->blocks = bd;
504
505
506
    // might have gone just under, by freeing a large block, so make
    // up the difference.
    if (nursery_blocks < blocks) {
507
	stp->blocks = allocNursery(stp, stp->blocks, blocks-nursery_blocks);
508
    }
509
510
  }
  
511
512
513
  stp->n_blocks = blocks;
  ASSERT(countBlocks(stp->blocks) == stp->n_blocks);
}
514

515
516
517
518
// 
// Resize each of the nurseries to the specified size.
//
void
519
resizeNurseriesFixed (nat blocks)
520
521
522
523
524
{
    nat i;
    for (i = 0; i < n_nurseries; i++) {
	resizeNursery(&nurseries[i], blocks);
    }
525
526
}

527
528
529
530
531
532
533
534
535
536
537
// 
// Resize the nurseries to the total specified size.
//
void
resizeNurseries (nat blocks)
{
    // If there are multiple nurseries, then we just divide the number
    // of available blocks between them.
    resizeNurseriesFixed(blocks / n_nurseries);
}

538
539
540
541
542
543
544
545
546
/* -----------------------------------------------------------------------------
   The allocate() interface

   allocate(n) always succeeds, and returns a chunk of memory n words
   long.  n can be larger than the size of a block if necessary, in
   which case a contiguous block group will be allocated.
   -------------------------------------------------------------------------- */

StgPtr
547
allocate( nat n )
548
{
549
550
    bdescr *bd;
    StgPtr p;
551

552
    ACQUIRE_SM_LOCK;
553

554
555
    TICK_ALLOC_HEAP_NOCTR(n);
    CCS_ALLOC(CCCS,n);
556

557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
    /* big allocation (>LARGE_OBJECT_THRESHOLD) */
    /* ToDo: allocate directly into generation 1 */
    if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
	nat req_blocks =  (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
	bd = allocGroup(req_blocks);
	dbl_link_onto(bd, &g0s0->large_objects);
	g0s0->n_large_blocks += req_blocks;
	bd->gen_no  = 0;
	bd->step = g0s0;
	bd->flags = BF_LARGE;
	bd->free = bd->start + n;
	alloc_blocks += req_blocks;
	RELEASE_SM_LOCK;
	return bd->start;
	
	/* small allocation (<LARGE_OBJECT_THRESHOLD) */
    } else if (small_alloc_list == NULL || alloc_Hp + n > alloc_HpLim) {
	if (small_alloc_list) {
	    small_alloc_list->free = alloc_Hp;
	}
	bd = allocBlock();
	bd->link = small_alloc_list;
	small_alloc_list = bd;
	bd->gen_no = 0;
	bd->step = g0s0;
	bd->flags = 0;
	alloc_Hp = bd->start;
	alloc_HpLim = bd->start + BLOCK_SIZE_W;
	alloc_blocks++;
586
    }
587
588
589
590
591
    
    p = alloc_Hp;
    alloc_Hp += n;
    RELEASE_SM_LOCK;
    return p;
592
593
}

594
595
lnat
allocated_bytes( void )
596
{
597
598
599
600
601
602
603
604
605
    lnat allocated;

    allocated = alloc_blocks * BLOCK_SIZE_W - (alloc_HpLim - alloc_Hp);
    if (pinned_object_block != NULL) {
	allocated -= (pinned_object_block->start + BLOCK_SIZE_W) - 
	    pinned_object_block->free;
    }
	
    return allocated;
606
607
}

608
609
610
611
612
613
614
615
616
617
void
tidyAllocateLists (void)
{
    if (small_alloc_list != NULL) {
	ASSERT(alloc_Hp >= small_alloc_list->start && 
	       alloc_Hp <= small_alloc_list->start + BLOCK_SIZE);
	small_alloc_list->free = alloc_Hp;
    }
}

618
619
620
621
622
623
624
625
626
627
628
629
630
631
/* -----------------------------------------------------------------------------
   allocateLocal()

   This allocates memory in the current thread - it is intended for
   use primarily from STG-land where we have a Capability.  It is
   better than allocate() because it doesn't require taking the
   sm_mutex lock in the common case.

   Memory is allocated directly from the nursery if possible (but not
   from the current nursery block, so as not to interfere with
   Hp/HpLim).
   -------------------------------------------------------------------------- */

StgPtr
632
allocateLocal (Capability *cap, nat n)
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
{
    bdescr *bd;
    StgPtr p;

    TICK_ALLOC_HEAP_NOCTR(n);
    CCS_ALLOC(CCCS,n);
    
    /* big allocation (>LARGE_OBJECT_THRESHOLD) */
    /* ToDo: allocate directly into generation 1 */
    if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
	nat req_blocks =  (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
	ACQUIRE_SM_LOCK;
	bd = allocGroup(req_blocks);
	dbl_link_onto(bd, &g0s0->large_objects);
	g0s0->n_large_blocks += req_blocks;
	bd->gen_no  = 0;
	bd->step = g0s0;
	bd->flags = BF_LARGE;
	bd->free = bd->start + n;
	alloc_blocks += req_blocks;
	RELEASE_SM_LOCK;
	return bd->start;
	
	/* small allocation (<LARGE_OBJECT_THRESHOLD) */
    } else {

659
	bd = cap->r.rCurrentAlloc;
660
661
662
663
664
	if (bd == NULL || bd->free + n > bd->start + BLOCK_SIZE_W) {

	    // The CurrentAlloc block is full, we need to find another
	    // one.  First, we try taking the next block from the
	    // nursery:
665
	    bd = cap->r.rCurrentNursery->link;
666
667
668
669
670
671

	    if (bd == NULL || bd->free + n > bd->start + BLOCK_SIZE_W) {
		// The nursery is empty, or the next block is already
		// full: allocate a fresh block (we can't fail here).
		ACQUIRE_SM_LOCK;
		bd = allocBlock();
672
		cap->r.rNursery->n_blocks++;
673
674
		RELEASE_SM_LOCK;
		bd->gen_no = 0;
675
		bd->step = cap->r.rNursery;
676
677
678
679
680
		bd->flags = 0;
	    } else {
		// we have a block in the nursery: take it and put
		// it at the *front* of the nursery list, and use it
		// to allocate() from.
681
		cap->r.rCurrentNursery->link = bd->link;
682
		if (bd->link != NULL) {
683
		    bd->link->u.back = cap->r.rCurrentNursery;
684
		}
685
	    }
686
687
688
	    dbl_link_onto(bd, &cap->r.rNursery->blocks);
	    cap->r.rCurrentAlloc = bd;
	    IF_DEBUG(sanity, checkNurserySanity(cap->r.rNursery));
689
690
691
692
693
694
695
	}
    }
    p = bd->free;
    bd->free += n;
    return p;
}

696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
/* ---------------------------------------------------------------------------
   Allocate a fixed/pinned object.

   We allocate small pinned objects into a single block, allocating a
   new block when the current one overflows.  The block is chained
   onto the large_object_list of generation 0 step 0.

   NOTE: The GC can't in general handle pinned objects.  This
   interface is only safe to use for ByteArrays, which have no
   pointers and don't require scavenging.  It works because the
   block's descriptor has the BF_LARGE flag set, so the block is
   treated as a large object and chained onto various lists, rather
   than the individual objects being copied.  However, when it comes
   to scavenge the block, the GC will only scavenge the first object.
   The reason is that the GC can't linearly scan a block of pinned
   objects at the moment (doing so would require using the
   mostly-copying techniques).  But since we're restricting ourselves
   to pinned ByteArrays, not scavenging is ok.

   This function is called by newPinnedByteArray# which immediately
   fills the allocated memory with a MutableByteArray#.
   ------------------------------------------------------------------------- */

StgPtr
allocatePinned( nat n )
{
    StgPtr p;
    bdescr *bd = pinned_object_block;

    // If the request is for a large object, then allocate()
    // will give us a pinned object anyway.
    if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
	return allocate(n);
    }

sof's avatar
sof committed
731
732
733
734
735
    ACQUIRE_SM_LOCK;
    
    TICK_ALLOC_HEAP_NOCTR(n);
    CCS_ALLOC(CCCS,n);

736
737
738
    // we always return 8-byte aligned memory.  bd->free must be
    // 8-byte aligned to begin with, so we just round up n to
    // the nearest multiple of 8 bytes.
739
740
741
    if (sizeof(StgWord) == 4) {
	n = (n+1) & ~1;
    }
742

743
744
745
746
747
748
749
    // If we don't have a block of pinned objects yet, or the current
    // one isn't large enough to hold the new object, allocate a new one.
    if (bd == NULL || (bd->free + n) > (bd->start + BLOCK_SIZE_W)) {
	pinned_object_block = bd = allocBlock();
	dbl_link_onto(bd, &g0s0->large_objects);
	bd->gen_no = 0;
	bd->step   = g0s0;
750
	bd->flags  = BF_PINNED | BF_LARGE;
751
752
753
754
755
756
	bd->free   = bd->start;
	alloc_blocks++;
    }

    p = bd->free;
    bd->free += n;
sof's avatar
sof committed
757
    RELEASE_SM_LOCK;
758
759
760
    return p;
}

761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
/* -----------------------------------------------------------------------------
   Allocation functions for GMP.

   These all use the allocate() interface - we can't have any garbage
   collection going on during a gmp operation, so we use allocate()
   which always succeeds.  The gmp operations which might need to
   allocate will ask the storage manager (via doYouWantToGC()) whether
   a garbage collection is required, in case we get into a loop doing
   only allocate() style allocation.
   -------------------------------------------------------------------------- */

static void *
stgAllocForGMP (size_t size_in_bytes)
{
  StgArrWords* arr;
  nat data_size_in_words, total_size_in_words;
  
778
779
  /* round up to a whole number of words */
  data_size_in_words  = (size_in_bytes + sizeof(W_) + 1) / sizeof(W_);
780
781
782
  total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
  
  /* allocate and fill it in. */
783
#if defined(SMP)
784
  arr = (StgArrWords *)allocateLocal(myTask()->cap, total_size_in_words);
785
#else
786
  arr = (StgArrWords *)allocateLocal(&MainCapability, total_size_in_words);
787
#endif
788
  SET_ARR_HDR(arr, &stg_ARR_WORDS_info, CCCS, data_size_in_words);
789
790
  
  /* and return a ptr to the goods inside the array */
791
  return arr->payload;
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
}

static void *
stgReallocForGMP (void *ptr, size_t old_size, size_t new_size)
{
    void *new_stuff_ptr = stgAllocForGMP(new_size);
    nat i = 0;
    char *p = (char *) ptr;
    char *q = (char *) new_stuff_ptr;

    for (; i < old_size; i++, p++, q++) {
	*q = *p;
    }

    return(new_stuff_ptr);
}

static void
stgDeallocForGMP (void *ptr STG_UNUSED, 
		  size_t size STG_UNUSED)
{
    /* easy for us: the garbage collector does the dealloc'n */
}
815

816
/* -----------------------------------------------------------------------------
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
 * Stats and stuff
 * -------------------------------------------------------------------------- */

/* -----------------------------------------------------------------------------
 * calcAllocated()
 *
 * Approximate how much we've allocated: number of blocks in the
 * nursery + blocks allocated via allocate() - unused nusery blocks.
 * This leaves a little slop at the end of each block, and doesn't
 * take into account large objects (ToDo).
 * -------------------------------------------------------------------------- */

lnat
calcAllocated( void )
{
  nat allocated;
  bdescr *bd;

835
  allocated = allocated_bytes();
836
  allocated += countNurseryBlocks() * BLOCK_SIZE_W;
837
  
838
  {
839
#ifdef SMP
840
  nat i;
841
842
  for (i = 0; i < n_nurseries; i++) {
      Capability *cap;
843
      for ( bd = capabilities[i].r.rCurrentNursery->link; 
844
845
846
847
848
849
850
851
852
	    bd != NULL; bd = bd->link ) {
	  allocated -= BLOCK_SIZE_W;
      }
      cap = &capabilities[i];
      if (cap->r.rCurrentNursery->free < 
	  cap->r.rCurrentNursery->start + BLOCK_SIZE_W) {
	  allocated -= (cap->r.rCurrentNursery->start + BLOCK_SIZE_W)
	      - cap->r.rCurrentNursery->free;
      }
853
  }
854
#else
855
  bdescr *current_nursery = MainCapability.r.rCurrentNursery;
856
857

  for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
858
      allocated -= BLOCK_SIZE_W;
859
860
  }
  if (current_nursery->free < current_nursery->start + BLOCK_SIZE_W) {
861
862
      allocated -= (current_nursery->start + BLOCK_SIZE_W)
	  - current_nursery->free;
863
864
  }
#endif
865
  }
866

867
  total_allocated += allocated;
868
869
  return allocated;
}  
870
871
872
873
874
875
876
877
878

/* Approximate the amount of live data in the heap.  To be called just
 * after garbage collection (see GarbageCollect()).
 */
extern lnat 
calcLive(void)
{
  nat g, s;
  lnat live = 0;
879
  step *stp;
880
881

  if (RtsFlags.GcFlags.generations == 1) {
882
    live = (g0s0->n_blocks - 1) * BLOCK_SIZE_W + 
883
      ((lnat)g0s0->hp_bd->free - (lnat)g0s0->hp_bd->start) / sizeof(W_);
884
    return live;
885
886
887
888
889
  }

  for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
    for (s = 0; s < generations[g].n_steps; s++) {
      /* approximate amount of live data (doesn't take into account slop
890
891
       * at end of each block).
       */
892
893
894
      if (g == 0 && s == 0) { 
	  continue; 
      }
895
      stp = &generations[g].steps[s];
896
      live += (stp->n_large_blocks + stp->n_blocks - 1) * BLOCK_SIZE_W;
897
898
899
900
      if (stp->hp_bd != NULL) {
	  live += ((lnat)stp->hp_bd->free - (lnat)stp->hp_bd->start) 
	      / sizeof(W_);
      }
901
902
903
      if (stp->scavd_hp != NULL) {
	  live -= (P_)(BLOCK_ROUND_UP(stp->scavd_hp)) - stp->scavd_hp;
      }
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
    }
  }
  return live;
}

/* Approximate the number of blocks that will be needed at the next
 * garbage collection.
 *
 * Assume: all data currently live will remain live.  Steps that will
 * be collected next time will therefore need twice as many blocks
 * since all the data will be copied.
 */
extern lnat 
calcNeeded(void)
{
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
    lnat needed = 0;
    nat g, s;
    step *stp;
    
    for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
	for (s = 0; s < generations[g].n_steps; s++) {
	    if (g == 0 && s == 0) { continue; }
	    stp = &generations[g].steps[s];
	    if (generations[g].steps[0].n_blocks +
		generations[g].steps[0].n_large_blocks 
		> generations[g].max_blocks
		&& stp->is_compacted == 0) {
		needed += 2 * stp->n_blocks;
	    } else {
		needed += stp->n_blocks;
	    }
	}
936
    }
937
    return needed;
938
939
}

940
941
942
943
944
945
946
947
948
949
/* -----------------------------------------------------------------------------
   Debugging

   memInventory() checks for memory leaks by counting up all the
   blocks we know about and comparing that to the number of blocks
   allegedly floating around in the system.
   -------------------------------------------------------------------------- */

#ifdef DEBUG

950
951
952
953
954
955
956
static lnat
stepBlocks (step *stp)
{
    lnat total_blocks;
    bdescr *bd;

    total_blocks = stp->n_blocks;    
957
    total_blocks += stp->n_old_blocks;
958
959
960
961
962
963
964
965
966
967
968
969
970
971
    for (bd = stp->large_objects; bd; bd = bd->link) {
	total_blocks += bd->blocks;
	/* hack for megablock groups: they have an extra block or two in
	   the second and subsequent megablocks where the block
	   descriptors would normally go.
	*/
	if (bd->blocks > BLOCKS_PER_MBLOCK) {
	    total_blocks -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
		* (bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE));
	}
    }
    return total_blocks;
}

972
void
973
974
memInventory(void)
{
975
  nat g, s, i;
976
  step *stp;
977
978
979
980
  bdescr *bd;
  lnat total_blocks = 0, free_blocks = 0;

  /* count the blocks we current have */
981

982
  for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
983
984
985
986
987
      for (i = 0; i < n_capabilities; i++) {
	  for (bd = capabilities[i].mut_lists[g]; bd != NULL; bd = bd->link) {
	      total_blocks += bd->blocks;
	  }
      }	  
988
989
      for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
	  total_blocks += bd->blocks;
990
      }
991
      for (s = 0; s < generations[g].n_steps; s++) {
992
	  if (g==0 && s==0) continue;
993
	  stp = &generations[g].steps[s];
994
	  total_blocks += stepBlocks(stp);
995
996
997
      }
  }

998
999
1000
  for (i = 0; i < n_nurseries; i++) {
      total_blocks += stepBlocks(&nurseries[i]);
  }