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