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