5bdaeee443acfbc399073b40d819aa75d9c32baf
[ghc.git] / rts / sm / Storage.c
1 /* -----------------------------------------------------------------------------
2 *
3 * (c) The GHC Team, 1998-2012
4 *
5 * Storage manager front end
6 *
7 * Documentation on the architecture of the Storage Manager can be
8 * found in the online commentary:
9 *
10 * http://hackage.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage
11 *
12 * ---------------------------------------------------------------------------*/
13
14 #include "PosixSource.h"
15 #include "Rts.h"
16
17 #include "Storage.h"
18 #include "GCThread.h"
19 #include "RtsUtils.h"
20 #include "Stats.h"
21 #include "BlockAlloc.h"
22 #include "Weak.h"
23 #include "Sanity.h"
24 #include "Arena.h"
25 #include "Capability.h"
26 #include "Schedule.h"
27 #include "RetainerProfile.h" // for counting memory blocks (memInventory)
28 #include "OSMem.h"
29 #include "Trace.h"
30 #include "GC.h"
31 #include "Evac.h"
32
33 #include <string.h>
34
35 #include "ffi.h"
36
37 /*
38 * All these globals require sm_mutex to access in THREADED_RTS mode.
39 */
40 StgClosure *caf_list = NULL;
41 StgClosure *revertible_caf_list = NULL;
42 rtsBool keepCAFs;
43
44 nat large_alloc_lim; /* GC if n_large_blocks in any nursery
45 * reaches this. */
46
47 bdescr *exec_block;
48
49 generation *generations = NULL; /* all the generations */
50 generation *g0 = NULL; /* generation 0, for convenience */
51 generation *oldest_gen = NULL; /* oldest generation, for convenience */
52
53 nursery *nurseries = NULL; /* array of nurseries, size == n_capabilities */
54
55 #ifdef THREADED_RTS
56 /*
57 * Storage manager mutex: protects all the above state from
58 * simultaneous access by two STG threads.
59 */
60 Mutex sm_mutex;
61 #endif
62
63 static void allocNurseries (nat from, nat to);
64
65 static void
66 initGeneration (generation *gen, int g)
67 {
68 gen->no = g;
69 gen->collections = 0;
70 gen->par_collections = 0;
71 gen->failed_promotions = 0;
72 gen->max_blocks = 0;
73 gen->blocks = NULL;
74 gen->n_blocks = 0;
75 gen->n_words = 0;
76 gen->live_estimate = 0;
77 gen->old_blocks = NULL;
78 gen->n_old_blocks = 0;
79 gen->large_objects = NULL;
80 gen->n_large_blocks = 0;
81 gen->n_new_large_words = 0;
82 gen->scavenged_large_objects = NULL;
83 gen->n_scavenged_large_blocks = 0;
84 gen->mark = 0;
85 gen->compact = 0;
86 gen->bitmap = NULL;
87 #ifdef THREADED_RTS
88 initSpinLock(&gen->sync);
89 #endif
90 gen->threads = END_TSO_QUEUE;
91 gen->old_threads = END_TSO_QUEUE;
92 }
93
94 void
95 initStorage (void)
96 {
97 nat g;
98
99 if (generations != NULL) {
100 // multi-init protection
101 return;
102 }
103
104 initMBlocks();
105
106 /* Sanity check to make sure the LOOKS_LIKE_ macros appear to be
107 * doing something reasonable.
108 */
109 /* We use the NOT_NULL variant or gcc warns that the test is always true */
110 ASSERT(LOOKS_LIKE_INFO_PTR_NOT_NULL((StgWord)&stg_BLOCKING_QUEUE_CLEAN_info));
111 ASSERT(LOOKS_LIKE_CLOSURE_PTR(&stg_dummy_ret_closure));
112 ASSERT(!HEAP_ALLOCED(&stg_dummy_ret_closure));
113
114 if (RtsFlags.GcFlags.maxHeapSize != 0 &&
115 RtsFlags.GcFlags.heapSizeSuggestion >
116 RtsFlags.GcFlags.maxHeapSize) {
117 RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion;
118 }
119
120 if (RtsFlags.GcFlags.maxHeapSize != 0 &&
121 RtsFlags.GcFlags.minAllocAreaSize >
122 RtsFlags.GcFlags.maxHeapSize) {
123 errorBelch("maximum heap size (-M) is smaller than minimum alloc area size (-A)");
124 RtsFlags.GcFlags.minAllocAreaSize = RtsFlags.GcFlags.maxHeapSize;
125 }
126
127 initBlockAllocator();
128
129 #if defined(THREADED_RTS)
130 initMutex(&sm_mutex);
131 #endif
132
133 ACQUIRE_SM_LOCK;
134
135 /* allocate generation info array */
136 generations = (generation *)stgMallocBytes(RtsFlags.GcFlags.generations
137 * sizeof(struct generation_),
138 "initStorage: gens");
139
140 /* Initialise all generations */
141 for(g = 0; g < RtsFlags.GcFlags.generations; g++) {
142 initGeneration(&generations[g], g);
143 }
144
145 /* A couple of convenience pointers */
146 g0 = &generations[0];
147 oldest_gen = &generations[RtsFlags.GcFlags.generations-1];
148
149 /* Set up the destination pointers in each younger gen. step */
150 for (g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
151 generations[g].to = &generations[g+1];
152 }
153 oldest_gen->to = oldest_gen;
154
155 /* The oldest generation has one step. */
156 if (RtsFlags.GcFlags.compact || RtsFlags.GcFlags.sweep) {
157 if (RtsFlags.GcFlags.generations == 1) {
158 errorBelch("WARNING: compact/sweep is incompatible with -G1; disabled");
159 } else {
160 oldest_gen->mark = 1;
161 if (RtsFlags.GcFlags.compact)
162 oldest_gen->compact = 1;
163 }
164 }
165
166 generations[0].max_blocks = 0;
167
168 weak_ptr_list = NULL;
169 caf_list = END_OF_STATIC_LIST;
170 revertible_caf_list = END_OF_STATIC_LIST;
171
172 /* initialise the allocate() interface */
173 large_alloc_lim = RtsFlags.GcFlags.minAllocAreaSize * BLOCK_SIZE_W;
174
175 exec_block = NULL;
176
177 #ifdef THREADED_RTS
178 initSpinLock(&gc_alloc_block_sync);
179 whitehole_spin = 0;
180 #endif
181
182 N = 0;
183
184 storageAddCapabilities(0, n_capabilities);
185
186 IF_DEBUG(gc, statDescribeGens());
187
188 RELEASE_SM_LOCK;
189
190 traceEventHeapInfo(CAPSET_HEAP_DEFAULT,
191 RtsFlags.GcFlags.generations,
192 RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE_W * sizeof(W_),
193 RtsFlags.GcFlags.minAllocAreaSize * BLOCK_SIZE_W * sizeof(W_),
194 MBLOCK_SIZE_W * sizeof(W_),
195 BLOCK_SIZE_W * sizeof(W_));
196 }
197
198 void storageAddCapabilities (nat from, nat to)
199 {
200 nat n, g, i;
201
202 if (from > 0) {
203 nurseries = stgReallocBytes(nurseries, to * sizeof(struct nursery_),
204 "storageAddCapabilities");
205 } else {
206 nurseries = stgMallocBytes(to * sizeof(struct nursery_),
207 "storageAddCapabilities");
208 }
209
210 // we've moved the nurseries, so we have to update the rNursery
211 // pointers from the Capabilities.
212 for (i = 0; i < to; i++) {
213 capabilities[i].r.rNursery = &nurseries[i];
214 }
215
216 /* The allocation area. Policy: keep the allocation area
217 * small to begin with, even if we have a large suggested heap
218 * size. Reason: we're going to do a major collection first, and we
219 * don't want it to be a big one. This vague idea is borne out by
220 * rigorous experimental evidence.
221 */
222 allocNurseries(from, to);
223
224 // allocate a block for each mut list
225 for (n = from; n < to; n++) {
226 for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
227 capabilities[n].mut_lists[g] = allocBlock();
228 }
229 }
230
231 initGcThreads(from, to);
232 }
233
234
235 void
236 exitStorage (void)
237 {
238 W_ allocated = updateNurseriesStats();
239 stat_exit(allocated);
240 }
241
242 void
243 freeStorage (rtsBool free_heap)
244 {
245 stgFree(generations);
246 if (free_heap) freeAllMBlocks();
247 #if defined(THREADED_RTS)
248 closeMutex(&sm_mutex);
249 #endif
250 stgFree(nurseries);
251 freeGcThreads();
252 }
253
254 /* -----------------------------------------------------------------------------
255 CAF management.
256
257 The entry code for every CAF does the following:
258
259 - builds a CAF_BLACKHOLE in the heap
260
261 - calls newCaf, which atomically updates the CAF with
262 IND_STATIC pointing to the CAF_BLACKHOLE
263
264 - if newCaf returns zero, it re-enters the CAF (see Note [atomic
265 CAF entry])
266
267 - pushes an update frame pointing to the CAF_BLACKHOLE
268
269 Why do we build an BLACKHOLE in the heap rather than just updating
270 the thunk directly? It's so that we only need one kind of update
271 frame - otherwise we'd need a static version of the update frame
272 too, and various other parts of the RTS that deal with update
273 frames would also need special cases for static update frames.
274
275 newCaf() does the following:
276
277 - it updates the CAF with an IND_STATIC pointing to the
278 CAF_BLACKHOLE, atomically.
279
280 - it puts the CAF on the oldest generation's mutable list.
281 This is so that we treat the CAF as a root when collecting
282 younger generations.
283
284 ------------------
285 Note [atomic CAF entry]
286
287 With THREADED_RTS, newCaf() is required to be atomic (see
288 #5558). This is because if two threads happened to enter the same
289 CAF simultaneously, they would create two distinct CAF_BLACKHOLEs,
290 and so the normal threadPaused() machinery for detecting duplicate
291 evaluation will not detect this. Hence in lockCAF() below, we
292 atomically lock the CAF with WHITEHOLE before updating it with
293 IND_STATIC, and return zero if another thread locked the CAF first.
294 In the event that we lost the race, CAF entry code will re-enter
295 the CAF and block on the other thread's CAF_BLACKHOLE.
296
297 ------------------
298 Note [GHCi CAFs]
299
300 For GHCI, we have additional requirements when dealing with CAFs:
301
302 - we must *retain* all dynamically-loaded CAFs ever entered,
303 just in case we need them again.
304 - we must be able to *revert* CAFs that have been evaluated, to
305 their pre-evaluated form.
306
307 To do this, we use an additional CAF list. When newCaf() is
308 called on a dynamically-loaded CAF, we add it to the CAF list
309 instead of the old-generation mutable list, and save away its
310 old info pointer (in caf->saved_info) for later reversion.
311
312 To revert all the CAFs, we traverse the CAF list and reset the
313 info pointer to caf->saved_info, then throw away the CAF list.
314 (see GC.c:revertCAFs()).
315
316 -- SDM 29/1/01
317
318 -------------------------------------------------------------------------- */
319
320 STATIC_INLINE StgWord lockCAF (StgClosure *caf, StgClosure *bh)
321 {
322 const StgInfoTable *orig_info;
323
324 orig_info = caf->header.info;
325
326 #ifdef THREADED_RTS
327 const StgInfoTable *cur_info;
328
329 if (orig_info == &stg_IND_STATIC_info ||
330 orig_info == &stg_WHITEHOLE_info) {
331 // already claimed by another thread; re-enter the CAF
332 return 0;
333 }
334
335 cur_info = (const StgInfoTable *)
336 cas((StgVolatilePtr)&caf->header.info,
337 (StgWord)orig_info,
338 (StgWord)&stg_WHITEHOLE_info);
339
340 if (cur_info != orig_info) {
341 // already claimed by another thread; re-enter the CAF
342 return 0;
343 }
344
345 // successfully claimed by us; overwrite with IND_STATIC
346 #endif
347
348 // For the benefit of revertCAFs(), save the original info pointer
349 ((StgIndStatic *)caf)->saved_info = orig_info;
350
351 ((StgIndStatic*)caf)->indirectee = bh;
352 write_barrier();
353 SET_INFO(caf,&stg_IND_STATIC_info);
354
355 return 1;
356 }
357
358 StgWord
359 newCAF(StgRegTable *reg, StgClosure *caf, StgClosure *bh)
360 {
361 if (lockCAF(caf,bh) == 0) return 0;
362
363 if(keepCAFs)
364 {
365 // HACK:
366 // If we are in GHCi _and_ we are using dynamic libraries,
367 // then we can't redirect newCAF calls to newDynCAF (see below),
368 // so we make newCAF behave almost like newDynCAF.
369 // The dynamic libraries might be used by both the interpreted
370 // program and GHCi itself, so they must not be reverted.
371 // This also means that in GHCi with dynamic libraries, CAFs are not
372 // garbage collected. If this turns out to be a problem, we could
373 // do another hack here and do an address range test on caf to figure
374 // out whether it is from a dynamic library.
375
376 ACQUIRE_SM_LOCK; // caf_list is global, locked by sm_mutex
377 ((StgIndStatic *)caf)->static_link = caf_list;
378 caf_list = caf;
379 RELEASE_SM_LOCK;
380 }
381 else
382 {
383 // Put this CAF on the mutable list for the old generation.
384 ((StgIndStatic *)caf)->saved_info = NULL;
385 if (oldest_gen->no != 0) {
386 recordMutableCap(caf, regTableToCapability(reg), oldest_gen->no);
387 }
388 }
389 return 1;
390 }
391
392 // External API for setting the keepCAFs flag. see #3900.
393 void
394 setKeepCAFs (void)
395 {
396 keepCAFs = 1;
397 }
398
399 // An alternate version of newCaf which is used for dynamically loaded
400 // object code in GHCi. In this case we want to retain *all* CAFs in
401 // the object code, because they might be demanded at any time from an
402 // expression evaluated on the command line.
403 // Also, GHCi might want to revert CAFs, so we add these to the
404 // revertible_caf_list.
405 //
406 // The linker hackily arranges that references to newCaf from dynamic
407 // code end up pointing to newDynCAF.
408 StgWord
409 newDynCAF (StgRegTable *reg STG_UNUSED, StgClosure *caf, StgClosure *bh)
410 {
411 if (lockCAF(caf,bh) == 0) return 0;
412
413 ACQUIRE_SM_LOCK;
414
415 ((StgIndStatic *)caf)->static_link = revertible_caf_list;
416 revertible_caf_list = caf;
417
418 RELEASE_SM_LOCK;
419
420 return 1;
421 }
422
423 /* -----------------------------------------------------------------------------
424 Nursery management.
425 -------------------------------------------------------------------------- */
426
427 static bdescr *
428 allocNursery (bdescr *tail, nat blocks)
429 {
430 bdescr *bd = NULL;
431 nat i, n;
432
433 // We allocate the nursery as a single contiguous block and then
434 // divide it into single blocks manually. This way we guarantee
435 // that the nursery blocks are adjacent, so that the processor's
436 // automatic prefetching works across nursery blocks. This is a
437 // tiny optimisation (~0.5%), but it's free.
438
439 while (blocks > 0) {
440 if (blocks >= BLOCKS_PER_MBLOCK / 4) {
441 n = stg_min(BLOCKS_PER_MBLOCK, blocks);
442 bd = allocLargeChunk(16, n); // see comment with allocLargeChunk()
443 // NB. we want a nice power of 2 for the minimum here
444 n = bd->blocks;
445 } else {
446 bd = allocGroup(blocks);
447 n = blocks;
448 }
449
450 blocks -= n;
451
452 for (i = 0; i < n; i++) {
453 initBdescr(&bd[i], g0, g0);
454
455 bd[i].blocks = 1;
456 bd[i].flags = 0;
457
458 if (i > 0) {
459 bd[i].u.back = &bd[i-1];
460 } else {
461 bd[i].u.back = NULL;
462 }
463
464 if (i+1 < n) {
465 bd[i].link = &bd[i+1];
466 } else {
467 bd[i].link = tail;
468 if (tail != NULL) {
469 tail->u.back = &bd[i];
470 }
471 }
472
473 bd[i].free = bd[i].start;
474 }
475
476 tail = &bd[0];
477 }
478
479 return &bd[0];
480 }
481
482 static void
483 assignNurseriesToCapabilities (nat from, nat to)
484 {
485 nat i;
486
487 for (i = from; i < to; i++) {
488 capabilities[i].r.rCurrentNursery = nurseries[i].blocks;
489 capabilities[i].r.rCurrentAlloc = NULL;
490 }
491 }
492
493 static void
494 allocNurseries (nat from, nat to)
495 {
496 nat i;
497
498 for (i = from; i < to; i++) {
499 nurseries[i].blocks =
500 allocNursery(NULL, RtsFlags.GcFlags.minAllocAreaSize);
501 nurseries[i].n_blocks =
502 RtsFlags.GcFlags.minAllocAreaSize;
503 }
504 assignNurseriesToCapabilities(from, to);
505 }
506
507 W_
508 clearNursery (Capability *cap)
509 {
510 bdescr *bd;
511 W_ allocated = 0;
512
513 for (bd = nurseries[cap->no].blocks; bd; bd = bd->link) {
514 allocated += (W_)(bd->free - bd->start);
515 cap->total_allocated += (W_)(bd->free - bd->start);
516 bd->free = bd->start;
517 ASSERT(bd->gen_no == 0);
518 ASSERT(bd->gen == g0);
519 IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
520 }
521
522 return allocated;
523 }
524
525 void
526 resetNurseries (void)
527 {
528 assignNurseriesToCapabilities(0, n_capabilities);
529 }
530
531 W_
532 countNurseryBlocks (void)
533 {
534 nat i;
535 W_ blocks = 0;
536
537 for (i = 0; i < n_capabilities; i++) {
538 blocks += nurseries[i].n_blocks;
539 }
540 return blocks;
541 }
542
543 static void
544 resizeNursery (nursery *nursery, nat blocks)
545 {
546 bdescr *bd;
547 nat nursery_blocks;
548
549 nursery_blocks = nursery->n_blocks;
550 if (nursery_blocks == blocks) return;
551
552 if (nursery_blocks < blocks) {
553 debugTrace(DEBUG_gc, "increasing size of nursery to %d blocks",
554 blocks);
555 nursery->blocks = allocNursery(nursery->blocks, blocks-nursery_blocks);
556 }
557 else {
558 bdescr *next_bd;
559
560 debugTrace(DEBUG_gc, "decreasing size of nursery to %d blocks",
561 blocks);
562
563 bd = nursery->blocks;
564 while (nursery_blocks > blocks) {
565 next_bd = bd->link;
566 next_bd->u.back = NULL;
567 nursery_blocks -= bd->blocks; // might be a large block
568 freeGroup(bd);
569 bd = next_bd;
570 }
571 nursery->blocks = bd;
572 // might have gone just under, by freeing a large block, so make
573 // up the difference.
574 if (nursery_blocks < blocks) {
575 nursery->blocks = allocNursery(nursery->blocks, blocks-nursery_blocks);
576 }
577 }
578
579 nursery->n_blocks = blocks;
580 ASSERT(countBlocks(nursery->blocks) == nursery->n_blocks);
581 }
582
583 //
584 // Resize each of the nurseries to the specified size.
585 //
586 void
587 resizeNurseriesFixed (nat blocks)
588 {
589 nat i;
590 for (i = 0; i < n_capabilities; i++) {
591 resizeNursery(&nurseries[i], blocks);
592 }
593 }
594
595 //
596 // Resize the nurseries to the total specified size.
597 //
598 void
599 resizeNurseries (nat blocks)
600 {
601 // If there are multiple nurseries, then we just divide the number
602 // of available blocks between them.
603 resizeNurseriesFixed(blocks / n_capabilities);
604 }
605
606
607 /* -----------------------------------------------------------------------------
608 move_STACK is called to update the TSO structure after it has been
609 moved from one place to another.
610 -------------------------------------------------------------------------- */
611
612 void
613 move_STACK (StgStack *src, StgStack *dest)
614 {
615 ptrdiff_t diff;
616
617 // relocate the stack pointer...
618 diff = (StgPtr)dest - (StgPtr)src; // In *words*
619 dest->sp = (StgPtr)dest->sp + diff;
620 }
621
622 /* -----------------------------------------------------------------------------
623 allocate()
624
625 This allocates memory in the current thread - it is intended for
626 use primarily from STG-land where we have a Capability. It is
627 better than allocate() because it doesn't require taking the
628 sm_mutex lock in the common case.
629
630 Memory is allocated directly from the nursery if possible (but not
631 from the current nursery block, so as not to interfere with
632 Hp/HpLim).
633 -------------------------------------------------------------------------- */
634
635 StgPtr
636 allocate (Capability *cap, W_ n)
637 {
638 bdescr *bd;
639 StgPtr p;
640
641 TICK_ALLOC_HEAP_NOCTR(n);
642 CCS_ALLOC(cap->r.rCCCS,n);
643
644 if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
645 W_ req_blocks = (W_)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
646
647 // Attempting to allocate an object larger than maxHeapSize
648 // should definitely be disallowed. (bug #1791)
649 if ((RtsFlags.GcFlags.maxHeapSize > 0 &&
650 req_blocks >= RtsFlags.GcFlags.maxHeapSize) ||
651 req_blocks >= HS_INT32_MAX) // avoid overflow when
652 // calling allocGroup() below
653 {
654 heapOverflow();
655 // heapOverflow() doesn't exit (see #2592), but we aren't
656 // in a position to do a clean shutdown here: we
657 // either have to allocate the memory or exit now.
658 // Allocating the memory would be bad, because the user
659 // has requested that we not exceed maxHeapSize, so we
660 // just exit.
661 stg_exit(EXIT_HEAPOVERFLOW);
662 }
663
664 ACQUIRE_SM_LOCK
665 bd = allocGroup(req_blocks);
666 dbl_link_onto(bd, &g0->large_objects);
667 g0->n_large_blocks += bd->blocks; // might be larger than req_blocks
668 g0->n_new_large_words += n;
669 RELEASE_SM_LOCK;
670 initBdescr(bd, g0, g0);
671 bd->flags = BF_LARGE;
672 bd->free = bd->start + n;
673 cap->total_allocated += n;
674 return bd->start;
675 }
676
677 /* small allocation (<LARGE_OBJECT_THRESHOLD) */
678
679 bd = cap->r.rCurrentAlloc;
680 if (bd == NULL || bd->free + n > bd->start + BLOCK_SIZE_W) {
681
682 // The CurrentAlloc block is full, we need to find another
683 // one. First, we try taking the next block from the
684 // nursery:
685 bd = cap->r.rCurrentNursery->link;
686
687 if (bd == NULL || bd->free + n > bd->start + BLOCK_SIZE_W) {
688 // The nursery is empty, or the next block is already
689 // full: allocate a fresh block (we can't fail here).
690 ACQUIRE_SM_LOCK;
691 bd = allocBlock();
692 cap->r.rNursery->n_blocks++;
693 RELEASE_SM_LOCK;
694 initBdescr(bd, g0, g0);
695 bd->flags = 0;
696 // If we had to allocate a new block, then we'll GC
697 // pretty quickly now, because MAYBE_GC() will
698 // notice that CurrentNursery->link is NULL.
699 } else {
700 // we have a block in the nursery: take it and put
701 // it at the *front* of the nursery list, and use it
702 // to allocate() from.
703 cap->r.rCurrentNursery->link = bd->link;
704 if (bd->link != NULL) {
705 bd->link->u.back = cap->r.rCurrentNursery;
706 }
707 }
708 dbl_link_onto(bd, &cap->r.rNursery->blocks);
709 cap->r.rCurrentAlloc = bd;
710 IF_DEBUG(sanity, checkNurserySanity(cap->r.rNursery));
711 }
712 p = bd->free;
713 bd->free += n;
714
715 IF_DEBUG(sanity, ASSERT(*((StgWord8*)p) == 0xaa));
716 return p;
717 }
718
719 /* ---------------------------------------------------------------------------
720 Allocate a fixed/pinned object.
721
722 We allocate small pinned objects into a single block, allocating a
723 new block when the current one overflows. The block is chained
724 onto the large_object_list of generation 0.
725
726 NOTE: The GC can't in general handle pinned objects. This
727 interface is only safe to use for ByteArrays, which have no
728 pointers and don't require scavenging. It works because the
729 block's descriptor has the BF_LARGE flag set, so the block is
730 treated as a large object and chained onto various lists, rather
731 than the individual objects being copied. However, when it comes
732 to scavenge the block, the GC will only scavenge the first object.
733 The reason is that the GC can't linearly scan a block of pinned
734 objects at the moment (doing so would require using the
735 mostly-copying techniques). But since we're restricting ourselves
736 to pinned ByteArrays, not scavenging is ok.
737
738 This function is called by newPinnedByteArray# which immediately
739 fills the allocated memory with a MutableByteArray#.
740 ------------------------------------------------------------------------- */
741
742 StgPtr
743 allocatePinned (Capability *cap, W_ n)
744 {
745 StgPtr p;
746 bdescr *bd;
747
748 // If the request is for a large object, then allocate()
749 // will give us a pinned object anyway.
750 if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
751 p = allocate(cap, n);
752 Bdescr(p)->flags |= BF_PINNED;
753 return p;
754 }
755
756 TICK_ALLOC_HEAP_NOCTR(n);
757 CCS_ALLOC(cap->r.rCCCS,n);
758
759 bd = cap->pinned_object_block;
760
761 // If we don't have a block of pinned objects yet, or the current
762 // one isn't large enough to hold the new object, get a new one.
763 if (bd == NULL || (bd->free + n) > (bd->start + BLOCK_SIZE_W)) {
764
765 // stash the old block on cap->pinned_object_blocks. On the
766 // next GC cycle these objects will be moved to
767 // g0->large_objects.
768 if (bd != NULL) {
769 dbl_link_onto(bd, &cap->pinned_object_blocks);
770 }
771
772 // We need to find another block. We could just allocate one,
773 // but that means taking a global lock and we really want to
774 // avoid that (benchmarks that allocate a lot of pinned
775 // objects scale really badly if we do this).
776 //
777 // So first, we try taking the next block from the nursery, in
778 // the same way as allocate(), but note that we can only take
779 // an *empty* block, because we're about to mark it as
780 // BF_PINNED | BF_LARGE.
781 bd = cap->r.rCurrentNursery->link;
782 if (bd == NULL || bd->free != bd->start) { // must be empty!
783 // The nursery is empty, or the next block is non-empty:
784 // allocate a fresh block (we can't fail here).
785
786 // XXX in the case when the next nursery block is
787 // non-empty we aren't exerting any pressure to GC soon,
788 // so if this case ever happens then we could in theory
789 // keep allocating for ever without calling the GC. We
790 // can't bump g0->n_new_large_words because that will be
791 // counted towards allocation, and we're already counting
792 // our pinned obects as allocation in
793 // collect_pinned_object_blocks in the GC.
794 ACQUIRE_SM_LOCK;
795 bd = allocBlock();
796 RELEASE_SM_LOCK;
797 initBdescr(bd, g0, g0);
798 } else {
799 // we have a block in the nursery: steal it
800 cap->r.rCurrentNursery->link = bd->link;
801 if (bd->link != NULL) {
802 bd->link->u.back = cap->r.rCurrentNursery;
803 }
804 cap->r.rNursery->n_blocks -= bd->blocks;
805 }
806
807 cap->pinned_object_block = bd;
808 bd->flags = BF_PINNED | BF_LARGE | BF_EVACUATED;
809
810 // The pinned_object_block remains attached to the capability
811 // until it is full, even if a GC occurs. We want this
812 // behaviour because otherwise the unallocated portion of the
813 // block would be forever slop, and under certain workloads
814 // (allocating a few ByteStrings per GC) we accumulate a lot
815 // of slop.
816 //
817 // So, the pinned_object_block is initially marked
818 // BF_EVACUATED so the GC won't touch it. When it is full,
819 // we place it on the large_objects list, and at the start of
820 // the next GC the BF_EVACUATED flag will be cleared, and the
821 // block will be promoted as usual (if anything in it is
822 // live).
823 }
824
825 p = bd->free;
826 bd->free += n;
827 return p;
828 }
829
830 /* -----------------------------------------------------------------------------
831 Write Barriers
832 -------------------------------------------------------------------------- */
833
834 /*
835 This is the write barrier for MUT_VARs, a.k.a. IORefs. A
836 MUT_VAR_CLEAN object is not on the mutable list; a MUT_VAR_DIRTY
837 is. When written to, a MUT_VAR_CLEAN turns into a MUT_VAR_DIRTY
838 and is put on the mutable list.
839 */
840 void
841 dirty_MUT_VAR(StgRegTable *reg, StgClosure *p)
842 {
843 Capability *cap = regTableToCapability(reg);
844 if (p->header.info == &stg_MUT_VAR_CLEAN_info) {
845 p->header.info = &stg_MUT_VAR_DIRTY_info;
846 recordClosureMutated(cap,p);
847 }
848 }
849
850 // Setting a TSO's link field with a write barrier.
851 // It is *not* necessary to call this function when
852 // * setting the link field to END_TSO_QUEUE
853 // * putting a TSO on the blackhole_queue
854 // * setting the link field of the currently running TSO, as it
855 // will already be dirty.
856 void
857 setTSOLink (Capability *cap, StgTSO *tso, StgTSO *target)
858 {
859 if (tso->dirty == 0) {
860 tso->dirty = 1;
861 recordClosureMutated(cap,(StgClosure*)tso);
862 }
863 tso->_link = target;
864 }
865
866 void
867 setTSOPrev (Capability *cap, StgTSO *tso, StgTSO *target)
868 {
869 if (tso->dirty == 0) {
870 tso->dirty = 1;
871 recordClosureMutated(cap,(StgClosure*)tso);
872 }
873 tso->block_info.prev = target;
874 }
875
876 void
877 dirty_TSO (Capability *cap, StgTSO *tso)
878 {
879 if (tso->dirty == 0) {
880 tso->dirty = 1;
881 recordClosureMutated(cap,(StgClosure*)tso);
882 }
883 }
884
885 void
886 dirty_STACK (Capability *cap, StgStack *stack)
887 {
888 if (stack->dirty == 0) {
889 stack->dirty = 1;
890 recordClosureMutated(cap,(StgClosure*)stack);
891 }
892 }
893
894 /*
895 This is the write barrier for MVARs. An MVAR_CLEAN objects is not
896 on the mutable list; a MVAR_DIRTY is. When written to, a
897 MVAR_CLEAN turns into a MVAR_DIRTY and is put on the mutable list.
898 The check for MVAR_CLEAN is inlined at the call site for speed,
899 this really does make a difference on concurrency-heavy benchmarks
900 such as Chaneneos and cheap-concurrency.
901 */
902 void
903 dirty_MVAR(StgRegTable *reg, StgClosure *p)
904 {
905 recordClosureMutated(regTableToCapability(reg),p);
906 }
907
908 /* -----------------------------------------------------------------------------
909 * Stats and stuff
910 * -------------------------------------------------------------------------- */
911
912 /* -----------------------------------------------------------------------------
913 * updateNurseriesStats()
914 *
915 * Update the per-cap total_allocated numbers with an approximation of
916 * the amount of memory used in each cap's nursery. Also return the
917 * total across all caps.
918 *
919 * Since this update is also performed by clearNurseries() then we only
920 * need this function for the final stats when the RTS is shutting down.
921 * -------------------------------------------------------------------------- */
922
923 W_
924 updateNurseriesStats (void)
925 {
926 W_ allocated = 0;
927 nat i;
928
929 for (i = 0; i < n_capabilities; i++) {
930 int cap_allocated = countOccupied(nurseries[i].blocks);
931 capabilities[i].total_allocated += cap_allocated;
932 allocated += cap_allocated;
933 }
934
935 return allocated;
936 }
937
938 W_
939 countLargeAllocated (void)
940 {
941 return g0->n_new_large_words;
942 }
943
944 W_ countOccupied (bdescr *bd)
945 {
946 W_ words;
947
948 words = 0;
949 for (; bd != NULL; bd = bd->link) {
950 ASSERT(bd->free <= bd->start + bd->blocks * BLOCK_SIZE_W);
951 words += bd->free - bd->start;
952 }
953 return words;
954 }
955
956 W_ genLiveWords (generation *gen)
957 {
958 return gen->n_words + countOccupied(gen->large_objects);
959 }
960
961 W_ genLiveBlocks (generation *gen)
962 {
963 return gen->n_blocks + gen->n_large_blocks;
964 }
965
966 W_ gcThreadLiveWords (nat i, nat g)
967 {
968 W_ words;
969
970 words = countOccupied(gc_threads[i]->gens[g].todo_bd);
971 words += countOccupied(gc_threads[i]->gens[g].part_list);
972 words += countOccupied(gc_threads[i]->gens[g].scavd_list);
973
974 return words;
975 }
976
977 W_ gcThreadLiveBlocks (nat i, nat g)
978 {
979 W_ blocks;
980
981 blocks = countBlocks(gc_threads[i]->gens[g].todo_bd);
982 blocks += gc_threads[i]->gens[g].n_part_blocks;
983 blocks += gc_threads[i]->gens[g].n_scavd_blocks;
984
985 return blocks;
986 }
987
988 // Return an accurate count of the live data in the heap, excluding
989 // generation 0.
990 W_ calcLiveWords (void)
991 {
992 nat g;
993 W_ live;
994
995 live = 0;
996 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
997 live += genLiveWords(&generations[g]);
998 }
999 return live;
1000 }
1001
1002 W_ calcLiveBlocks (void)
1003 {
1004 nat g;
1005 W_ live;
1006
1007 live = 0;
1008 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1009 live += genLiveBlocks(&generations[g]);
1010 }
1011 return live;
1012 }
1013
1014 /* Determine which generation will be collected next, and approximate
1015 * the maximum amount of memory that will be required to do the GC,
1016 * taking into account data that will be copied, and the space needed
1017 * to store bitmaps and the mark stack. Note: blocks_needed does not
1018 * include the blocks in the nursery.
1019 *
1020 * Assume: all data currently live will remain live. Generationss
1021 * that will be collected next time will therefore need twice as many
1022 * blocks since all the data will be copied.
1023 */
1024 extern W_
1025 calcNeeded (rtsBool force_major, memcount *blocks_needed)
1026 {
1027 W_ needed = 0, blocks;
1028 nat g, N;
1029 generation *gen;
1030
1031 if (force_major) {
1032 N = RtsFlags.GcFlags.generations - 1;
1033 } else {
1034 N = 0;
1035 }
1036
1037 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1038 gen = &generations[g];
1039
1040 blocks = gen->n_blocks // or: gen->n_words / BLOCK_SIZE_W (?)
1041 + gen->n_large_blocks;
1042
1043 // we need at least this much space
1044 needed += blocks;
1045
1046 // are we collecting this gen?
1047 if (g == 0 || // always collect gen 0
1048 blocks > gen->max_blocks)
1049 {
1050 N = stg_max(N,g);
1051
1052 // we will collect this gen next time
1053 if (gen->mark) {
1054 // bitmap:
1055 needed += gen->n_blocks / BITS_IN(W_);
1056 // mark stack:
1057 needed += gen->n_blocks / 100;
1058 }
1059 if (gen->compact) {
1060 continue; // no additional space needed for compaction
1061 } else {
1062 needed += gen->n_blocks;
1063 }
1064 }
1065 }
1066
1067 if (blocks_needed != NULL) {
1068 *blocks_needed = needed;
1069 }
1070 return N;
1071 }
1072
1073 /* ----------------------------------------------------------------------------
1074 Executable memory
1075
1076 Executable memory must be managed separately from non-executable
1077 memory. Most OSs these days require you to jump through hoops to
1078 dynamically allocate executable memory, due to various security
1079 measures.
1080
1081 Here we provide a small memory allocator for executable memory.
1082 Memory is managed with a page granularity; we allocate linearly
1083 in the page, and when the page is emptied (all objects on the page
1084 are free) we free the page again, not forgetting to make it
1085 non-executable.
1086
1087 TODO: The inability to handle objects bigger than BLOCK_SIZE_W means that
1088 the linker cannot use allocateExec for loading object code files
1089 on Windows. Once allocateExec can handle larger objects, the linker
1090 should be modified to use allocateExec instead of VirtualAlloc.
1091 ------------------------------------------------------------------------- */
1092
1093 #if defined(linux_HOST_OS)
1094
1095 // On Linux we need to use libffi for allocating executable memory,
1096 // because it knows how to work around the restrictions put in place
1097 // by SELinux.
1098
1099 void *allocateExec (nat bytes, void **exec_ret)
1100 {
1101 void **ret, **exec;
1102 ACQUIRE_SM_LOCK;
1103 ret = ffi_closure_alloc (sizeof(void *) + (size_t)bytes, (void**)&exec);
1104 RELEASE_SM_LOCK;
1105 if (ret == NULL) return ret;
1106 *ret = ret; // save the address of the writable mapping, for freeExec().
1107 *exec_ret = exec + 1;
1108 return (ret + 1);
1109 }
1110
1111 // freeExec gets passed the executable address, not the writable address.
1112 void freeExec (void *addr)
1113 {
1114 void *writable;
1115 writable = *((void**)addr - 1);
1116 ACQUIRE_SM_LOCK;
1117 ffi_closure_free (writable);
1118 RELEASE_SM_LOCK
1119 }
1120
1121 #else
1122
1123 void *allocateExec (nat bytes, void **exec_ret)
1124 {
1125 void *ret;
1126 nat n;
1127
1128 ACQUIRE_SM_LOCK;
1129
1130 // round up to words.
1131 n = (bytes + sizeof(W_) + 1) / sizeof(W_);
1132
1133 if (n+1 > BLOCK_SIZE_W) {
1134 barf("allocateExec: can't handle large objects");
1135 }
1136
1137 if (exec_block == NULL ||
1138 exec_block->free + n + 1 > exec_block->start + BLOCK_SIZE_W) {
1139 bdescr *bd;
1140 W_ pagesize = getPageSize();
1141 bd = allocGroup(stg_max(1, pagesize / BLOCK_SIZE));
1142 debugTrace(DEBUG_gc, "allocate exec block %p", bd->start);
1143 bd->gen_no = 0;
1144 bd->flags = BF_EXEC;
1145 bd->link = exec_block;
1146 if (exec_block != NULL) {
1147 exec_block->u.back = bd;
1148 }
1149 bd->u.back = NULL;
1150 setExecutable(bd->start, bd->blocks * BLOCK_SIZE, rtsTrue);
1151 exec_block = bd;
1152 }
1153 *(exec_block->free) = n; // store the size of this chunk
1154 exec_block->gen_no += n; // gen_no stores the number of words allocated
1155 ret = exec_block->free + 1;
1156 exec_block->free += n + 1;
1157
1158 RELEASE_SM_LOCK
1159 *exec_ret = ret;
1160 return ret;
1161 }
1162
1163 void freeExec (void *addr)
1164 {
1165 StgPtr p = (StgPtr)addr - 1;
1166 bdescr *bd = Bdescr((StgPtr)p);
1167
1168 if ((bd->flags & BF_EXEC) == 0) {
1169 barf("freeExec: not executable");
1170 }
1171
1172 if (*(StgPtr)p == 0) {
1173 barf("freeExec: already free?");
1174 }
1175
1176 ACQUIRE_SM_LOCK;
1177
1178 bd->gen_no -= *(StgPtr)p;
1179 *(StgPtr)p = 0;
1180
1181 if (bd->gen_no == 0) {
1182 // Free the block if it is empty, but not if it is the block at
1183 // the head of the queue.
1184 if (bd != exec_block) {
1185 debugTrace(DEBUG_gc, "free exec block %p", bd->start);
1186 dbl_link_remove(bd, &exec_block);
1187 setExecutable(bd->start, bd->blocks * BLOCK_SIZE, rtsFalse);
1188 freeGroup(bd);
1189 } else {
1190 bd->free = bd->start;
1191 }
1192 }
1193
1194 RELEASE_SM_LOCK
1195 }
1196
1197 #endif /* mingw32_HOST_OS */
1198
1199 #ifdef DEBUG
1200
1201 // handy function for use in gdb, because Bdescr() is inlined.
1202 extern bdescr *_bdescr (StgPtr p);
1203
1204 bdescr *
1205 _bdescr (StgPtr p)
1206 {
1207 return Bdescr(p);
1208 }
1209
1210 #endif