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