a8559e7e0030d47aa8fe7823acff5375690ff465
[ghc.git] / rts / sm / Evac.c
1 /* -----------------------------------------------------------------------------
2 *
3 * (c) The GHC Team 1998-2008
4 *
5 * Generational garbage collector: evacuation functions
6 *
7 * Documentation on the architecture of the Garbage Collector can be
8 * found in the online commentary:
9 *
10 * http://ghc.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/GC
11 *
12 * ---------------------------------------------------------------------------*/
13
14 #include "PosixSource.h"
15 #include "Rts.h"
16
17 #include "Evac.h"
18 #include "Storage.h"
19 #include "GC.h"
20 #include "GCThread.h"
21 #include "GCTDecl.h"
22 #include "GCUtils.h"
23 #include "Compact.h"
24 #include "MarkStack.h"
25 #include "Prelude.h"
26 #include "Trace.h"
27 #include "LdvProfile.h"
28 #include "CNF.h"
29 #include "Scav.h"
30
31 #if defined(THREADED_RTS) && !defined(PARALLEL_GC)
32 #define evacuate(p) evacuate1(p)
33 #define evacuate_BLACKHOLE(p) evacuate_BLACKHOLE1(p)
34 #define HEAP_ALLOCED_GC(p) HEAP_ALLOCED(p)
35 #endif
36
37 #if !defined(PARALLEL_GC) || defined(PROFILING)
38 #define copy_tag_nolock(p, info, src, size, stp, tag) \
39 copy_tag(p, info, src, size, stp, tag)
40 #endif
41
42 /* Used to avoid long recursion due to selector thunks
43 */
44 #define MAX_THUNK_SELECTOR_DEPTH 16
45
46 static void eval_thunk_selector (StgClosure **q, StgSelector * p, bool);
47 STATIC_INLINE void evacuate_large(StgPtr p);
48
49 /* -----------------------------------------------------------------------------
50 Allocate some space in which to copy an object.
51 -------------------------------------------------------------------------- */
52
53 STATIC_INLINE StgPtr
54 alloc_for_copy (uint32_t size, uint32_t gen_no)
55 {
56 StgPtr to;
57 gen_workspace *ws;
58
59 /* Find out where we're going, using the handy "to" pointer in
60 * the gen of the source object. If it turns out we need to
61 * evacuate to an older generation, adjust it here (see comment
62 * by evacuate()).
63 */
64 if (gen_no < gct->evac_gen_no) {
65 if (gct->eager_promotion) {
66 gen_no = gct->evac_gen_no;
67 } else {
68 gct->failed_to_evac = true;
69 }
70 }
71
72 ws = &gct->gens[gen_no]; // zero memory references here
73
74 /* chain a new block onto the to-space for the destination gen if
75 * necessary.
76 */
77 to = ws->todo_free;
78 ws->todo_free += size;
79 if (ws->todo_free > ws->todo_lim) {
80 to = todo_block_full(size, ws);
81 }
82 ASSERT(ws->todo_free >= ws->todo_bd->free && ws->todo_free <= ws->todo_lim);
83
84 return to;
85 }
86
87 /* -----------------------------------------------------------------------------
88 The evacuate() code
89 -------------------------------------------------------------------------- */
90
91 STATIC_INLINE GNUC_ATTR_HOT void
92 copy_tag(StgClosure **p, const StgInfoTable *info,
93 StgClosure *src, uint32_t size, uint32_t gen_no, StgWord tag)
94 {
95 StgPtr to, from;
96 uint32_t i;
97
98 to = alloc_for_copy(size,gen_no);
99
100 from = (StgPtr)src;
101 to[0] = (W_)info;
102 for (i = 1; i < size; i++) { // unroll for small i
103 to[i] = from[i];
104 }
105
106 // if (to+size+2 < bd->start + BLOCK_SIZE_W) {
107 // __builtin_prefetch(to + size + 2, 1);
108 // }
109
110 #if defined(PARALLEL_GC)
111 {
112 const StgInfoTable *new_info;
113 new_info = (const StgInfoTable *)cas((StgPtr)&src->header.info, (W_)info, MK_FORWARDING_PTR(to));
114 if (new_info != info) {
115 #if defined(PROFILING)
116 // We copied this object at the same time as another
117 // thread. We'll evacuate the object again and the copy
118 // we just made will be discarded at the next GC, but we
119 // may have copied it after the other thread called
120 // SET_EVACUAEE_FOR_LDV(), which would confuse the LDV
121 // profiler when it encounters this closure in
122 // processHeapClosureForDead. So we reset the LDVW field
123 // here.
124 LDVW(to) = 0;
125 #endif
126 return evacuate(p); // does the failed_to_evac stuff
127 } else {
128 *p = TAG_CLOSURE(tag,(StgClosure*)to);
129 }
130 }
131 #else
132 src->header.info = (const StgInfoTable *)MK_FORWARDING_PTR(to);
133 *p = TAG_CLOSURE(tag,(StgClosure*)to);
134 #endif
135
136 #if defined(PROFILING)
137 // We store the size of the just evacuated object in the LDV word so that
138 // the profiler can guess the position of the next object later.
139 // This is safe only if we are sure that no other thread evacuates
140 // the object again, so we cannot use copy_tag_nolock when PROFILING.
141 SET_EVACUAEE_FOR_LDV(from, size);
142 #endif
143 }
144
145 #if defined(PARALLEL_GC) && !defined(PROFILING)
146 STATIC_INLINE void
147 copy_tag_nolock(StgClosure **p, const StgInfoTable *info,
148 StgClosure *src, uint32_t size, uint32_t gen_no, StgWord tag)
149 {
150 StgPtr to, from;
151 uint32_t i;
152
153 to = alloc_for_copy(size,gen_no);
154
155 from = (StgPtr)src;
156 to[0] = (W_)info;
157 for (i = 1; i < size; i++) { // unroll for small i
158 to[i] = from[i];
159 }
160
161 // if somebody else reads the forwarding pointer, we better make
162 // sure there's a closure at the end of it.
163 write_barrier();
164 *p = TAG_CLOSURE(tag,(StgClosure*)to);
165 src->header.info = (const StgInfoTable *)MK_FORWARDING_PTR(to);
166
167 // if (to+size+2 < bd->start + BLOCK_SIZE_W) {
168 // __builtin_prefetch(to + size + 2, 1);
169 // }
170
171 #if defined(PROFILING)
172 // We store the size of the just evacuated object in the LDV word so that
173 // the profiler can guess the position of the next object later.
174 SET_EVACUAEE_FOR_LDV(from, size);
175 #endif
176 }
177 #endif
178
179 /* Special version of copy() for when we only want to copy the info
180 * pointer of an object, but reserve some padding after it. This is
181 * used to optimise evacuation of TSOs.
182 */
183 static bool
184 copyPart(StgClosure **p, StgClosure *src, uint32_t size_to_reserve,
185 uint32_t size_to_copy, uint32_t gen_no)
186 {
187 StgPtr to, from;
188 uint32_t i;
189 StgWord info;
190
191 #if defined(PARALLEL_GC)
192 spin:
193 info = xchg((StgPtr)&src->header.info, (W_)&stg_WHITEHOLE_info);
194 if (info == (W_)&stg_WHITEHOLE_info) {
195 #if defined(PROF_SPIN)
196 whitehole_gc_spin++;
197 #endif
198 busy_wait_nop();
199 goto spin;
200 }
201 if (IS_FORWARDING_PTR(info)) {
202 src->header.info = (const StgInfoTable *)info;
203 evacuate(p); // does the failed_to_evac stuff
204 return false;
205 }
206 #else
207 info = (W_)src->header.info;
208 #endif
209
210 to = alloc_for_copy(size_to_reserve, gen_no);
211
212 from = (StgPtr)src;
213 to[0] = info;
214 for (i = 1; i < size_to_copy; i++) { // unroll for small i
215 to[i] = from[i];
216 }
217
218 write_barrier();
219 src->header.info = (const StgInfoTable*)MK_FORWARDING_PTR(to);
220 *p = (StgClosure *)to;
221
222 #if defined(PROFILING)
223 // We store the size of the just evacuated object in the LDV word so that
224 // the profiler can guess the position of the next object later.
225 SET_EVACUAEE_FOR_LDV(from, size_to_reserve);
226 // fill the slop
227 if (size_to_reserve - size_to_copy > 0)
228 LDV_FILL_SLOP(to + size_to_copy, (int)(size_to_reserve - size_to_copy));
229 #endif
230
231 return true;
232 }
233
234
235 /* Copy wrappers that don't tag the closure after copying */
236 STATIC_INLINE GNUC_ATTR_HOT void
237 copy(StgClosure **p, const StgInfoTable *info,
238 StgClosure *src, uint32_t size, uint32_t gen_no)
239 {
240 copy_tag(p,info,src,size,gen_no,0);
241 }
242
243 /* -----------------------------------------------------------------------------
244 Evacuate a large object
245
246 This just consists of removing the object from the (doubly-linked)
247 gen->large_objects list, and linking it on to the (singly-linked)
248 gct->todo_large_objects list, from where it will be scavenged later.
249
250 Convention: bd->flags has BF_EVACUATED set for a large object
251 that has been evacuated, or unset otherwise.
252 -------------------------------------------------------------------------- */
253
254 STATIC_INLINE void
255 evacuate_large(StgPtr p)
256 {
257 bdescr *bd;
258 generation *gen, *new_gen;
259 uint32_t gen_no, new_gen_no;
260 gen_workspace *ws;
261
262 bd = Bdescr(p);
263 gen = bd->gen;
264 gen_no = bd->gen_no;
265 ACQUIRE_SPIN_LOCK(&gen->sync);
266
267 // already evacuated?
268 if (bd->flags & BF_EVACUATED) {
269 /* Don't forget to set the gct->failed_to_evac flag if we didn't get
270 * the desired destination (see comments in evacuate()).
271 */
272 if (gen_no < gct->evac_gen_no) {
273 gct->failed_to_evac = true;
274 TICK_GC_FAILED_PROMOTION();
275 }
276 RELEASE_SPIN_LOCK(&gen->sync);
277 return;
278 }
279
280 // remove from large_object list
281 if (bd->u.back) {
282 bd->u.back->link = bd->link;
283 } else { // first object in the list
284 gen->large_objects = bd->link;
285 }
286 if (bd->link) {
287 bd->link->u.back = bd->u.back;
288 }
289
290 /* link it on to the evacuated large object list of the destination gen
291 */
292 new_gen_no = bd->dest_no;
293
294 if (new_gen_no < gct->evac_gen_no) {
295 if (gct->eager_promotion) {
296 new_gen_no = gct->evac_gen_no;
297 } else {
298 gct->failed_to_evac = true;
299 }
300 }
301
302 ws = &gct->gens[new_gen_no];
303 new_gen = &generations[new_gen_no];
304
305 bd->flags |= BF_EVACUATED;
306 initBdescr(bd, new_gen, new_gen->to);
307
308 // If this is a block of pinned or compact objects, we don't have to scan
309 // these objects, because they aren't allowed to contain any outgoing
310 // pointers. For these blocks, we skip the scavenge stage and put
311 // them straight on the scavenged_large_objects list.
312 if (bd->flags & BF_PINNED) {
313 ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS);
314
315 if (new_gen != gen) { ACQUIRE_SPIN_LOCK(&new_gen->sync); }
316 dbl_link_onto(bd, &new_gen->scavenged_large_objects);
317 new_gen->n_scavenged_large_blocks += bd->blocks;
318 if (new_gen != gen) { RELEASE_SPIN_LOCK(&new_gen->sync); }
319 } else {
320 bd->link = ws->todo_large_objects;
321 ws->todo_large_objects = bd;
322 }
323
324 RELEASE_SPIN_LOCK(&gen->sync);
325 }
326
327 /* ----------------------------------------------------------------------------
328 Evacuate static objects
329
330 When a static object is visited for the first time in this GC, it
331 is chained on to the gct->static_objects list.
332
333 evacuate_static_object (link_field, q)
334 - link_field must be STATIC_LINK(q)
335 ------------------------------------------------------------------------- */
336
337 STATIC_INLINE void
338 evacuate_static_object (StgClosure **link_field, StgClosure *q)
339 {
340 StgWord link = (StgWord)*link_field;
341
342 // See Note [STATIC_LINK fields] for how the link field bits work
343 if ((((StgWord)(link)&STATIC_BITS) | prev_static_flag) != 3) {
344 StgWord new_list_head = (StgWord)q | static_flag;
345 #if !defined(THREADED_RTS)
346 *link_field = gct->static_objects;
347 gct->static_objects = (StgClosure *)new_list_head;
348 #else
349 StgWord prev;
350 prev = cas((StgVolatilePtr)link_field, link,
351 (StgWord)gct->static_objects);
352 if (prev == link) {
353 gct->static_objects = (StgClosure *)new_list_head;
354 }
355 #endif
356 }
357 }
358
359 /* ----------------------------------------------------------------------------
360 Evacuate an object inside a CompactNFData
361
362 These are treated in a similar way to large objects. We remove the block
363 from the compact_objects list of the generation it is on, and link it onto
364 the live_compact_objects list of the destination generation.
365
366 It is assumed that objects in the struct live in the same generation
367 as the struct itself all the time.
368 ------------------------------------------------------------------------- */
369 STATIC_INLINE void
370 evacuate_compact (StgPtr p)
371 {
372 StgCompactNFData *str;
373 bdescr *bd;
374 generation *gen, *new_gen;
375 uint32_t gen_no, new_gen_no;
376
377 // We need to find the Compact# corresponding to this pointer, because it
378 // will give us the first block in the compact chain, which is the one we
379 // that gets linked onto the compact_objects list.
380 str = objectGetCompact((StgClosure*)p);
381 ASSERT(get_itbl((StgClosure*)str)->type == COMPACT_NFDATA);
382
383 bd = Bdescr((StgPtr)str);
384 gen_no = bd->gen_no;
385
386 // already evacuated? (we're about to do the same check,
387 // but we avoid taking the spin-lock)
388 if (bd->flags & BF_EVACUATED) {
389 /* Don't forget to set the gct->failed_to_evac flag if we didn't get
390 * the desired destination (see comments in evacuate()).
391 */
392 if (gen_no < gct->evac_gen_no) {
393 gct->failed_to_evac = true;
394 TICK_GC_FAILED_PROMOTION();
395 }
396 return;
397 }
398
399 gen = bd->gen;
400 gen_no = bd->gen_no;
401 ACQUIRE_SPIN_LOCK(&gen->sync);
402
403 // already evacuated?
404 if (bd->flags & BF_EVACUATED) {
405 /* Don't forget to set the gct->failed_to_evac flag if we didn't get
406 * the desired destination (see comments in evacuate()).
407 */
408 if (gen_no < gct->evac_gen_no) {
409 gct->failed_to_evac = true;
410 TICK_GC_FAILED_PROMOTION();
411 }
412 RELEASE_SPIN_LOCK(&gen->sync);
413 return;
414 }
415
416 // remove from compact_objects list
417 if (bd->u.back) {
418 bd->u.back->link = bd->link;
419 } else { // first object in the list
420 gen->compact_objects = bd->link;
421 }
422 if (bd->link) {
423 bd->link->u.back = bd->u.back;
424 }
425
426 /* link it on to the evacuated compact object list of the destination gen
427 */
428 new_gen_no = bd->dest_no;
429
430 if (new_gen_no < gct->evac_gen_no) {
431 if (gct->eager_promotion) {
432 new_gen_no = gct->evac_gen_no;
433 } else {
434 gct->failed_to_evac = true;
435 }
436 }
437
438 new_gen = &generations[new_gen_no];
439
440 // Note: for speed we only update the generation of the first block here
441 // This means that bdescr of subsequent blocks will think they are in
442 // the wrong generation
443 // (This should not be a problem because there is no code that checks
444 // for that - the only code touching the generation of the block is
445 // in the GC, and that should never see blocks other than the first)
446 bd->flags |= BF_EVACUATED;
447 initBdescr(bd, new_gen, new_gen->to);
448
449 if (str->hash) {
450 gen_workspace *ws = &gct->gens[new_gen_no];
451 bd->link = ws->todo_large_objects;
452 ws->todo_large_objects = bd;
453 } else {
454 if (new_gen != gen) { ACQUIRE_SPIN_LOCK(&new_gen->sync); }
455 dbl_link_onto(bd, &new_gen->live_compact_objects);
456 new_gen->n_live_compact_blocks += str->totalW / BLOCK_SIZE_W;
457 if (new_gen != gen) { RELEASE_SPIN_LOCK(&new_gen->sync); }
458 }
459
460 RELEASE_SPIN_LOCK(&gen->sync);
461
462 // Note: the object did not move in memory, because it lives
463 // in pinned (BF_COMPACT) allocation, so we do not need to rewrite it
464 // or muck with forwarding pointers
465 // Also there is no tag to worry about on the struct (tags are used
466 // for constructors and functions, but a struct is neither). There
467 // might be a tag on the object pointer, but again we don't change
468 // the pointer because we don't move the object so we don't need to
469 // rewrite the tag.
470 }
471
472 /* ----------------------------------------------------------------------------
473 Evacuate
474
475 This is called (eventually) for every live object in the system.
476
477 The caller to evacuate specifies a desired generation in the
478 gct->evac_gen thread-local variable. The following conditions apply to
479 evacuating an object which resides in generation M when we're
480 collecting up to generation N
481
482 if M >= gct->evac_gen
483 if M > N do nothing
484 else evac to gen->to
485
486 if M < gct->evac_gen evac to gct->evac_gen, step 0
487
488 if the object is already evacuated, then we check which generation
489 it now resides in.
490
491 if M >= gct->evac_gen do nothing
492 if M < gct->evac_gen set gct->failed_to_evac flag to indicate that we
493 didn't manage to evacuate this object into gct->evac_gen.
494
495
496 OPTIMISATION NOTES:
497
498 evacuate() is the single most important function performance-wise
499 in the GC. Various things have been tried to speed it up, but as
500 far as I can tell the code generated by gcc 3.2 with -O2 is about
501 as good as it's going to get. We pass the argument to evacuate()
502 in a register using the 'regparm' attribute (see the prototype for
503 evacuate() near the top of this file).
504
505 Changing evacuate() to take an (StgClosure **) rather than
506 returning the new pointer seems attractive, because we can avoid
507 writing back the pointer when it hasn't changed (eg. for a static
508 object, or an object in a generation > N). However, I tried it and
509 it doesn't help. One reason is that the (StgClosure **) pointer
510 gets spilled to the stack inside evacuate(), resulting in far more
511 extra reads/writes than we save.
512 ------------------------------------------------------------------------- */
513
514 REGPARM1 GNUC_ATTR_HOT void
515 evacuate(StgClosure **p)
516 {
517 bdescr *bd = NULL;
518 uint32_t gen_no;
519 StgClosure *q;
520 const StgInfoTable *info;
521 StgWord tag;
522
523 q = *p;
524
525 loop:
526 /* The tag and the pointer are split, to be merged after evacing */
527 tag = GET_CLOSURE_TAG(q);
528 q = UNTAG_CLOSURE(q);
529
530 ASSERTM(LOOKS_LIKE_CLOSURE_PTR(q), "invalid closure, info=%p", q->header.info);
531
532 if (!HEAP_ALLOCED_GC(q)) {
533 if (!major_gc) return;
534
535 info = get_itbl(q);
536 switch (info->type) {
537
538 case THUNK_STATIC:
539 if (info->srt != 0) {
540 evacuate_static_object(THUNK_STATIC_LINK((StgClosure *)q), q);
541 }
542 return;
543
544 case FUN_STATIC:
545 if (info->srt != 0) {
546 evacuate_static_object(FUN_STATIC_LINK((StgClosure *)q), q);
547 }
548 return;
549
550 case IND_STATIC:
551 /* If q->saved_info != NULL, then it's a revertible CAF - it'll be
552 * on the CAF list, so don't do anything with it here (we'll
553 * scavenge it later).
554 */
555 evacuate_static_object(IND_STATIC_LINK((StgClosure *)q), q);
556 return;
557
558 case CONSTR:
559 case CONSTR_1_0:
560 case CONSTR_2_0:
561 case CONSTR_1_1:
562 evacuate_static_object(STATIC_LINK(info,(StgClosure *)q), q);
563 return;
564
565 case CONSTR_0_1:
566 case CONSTR_0_2:
567 case CONSTR_NOCAF:
568 /* no need to put these on the static linked list, they don't need
569 * to be scavenged.
570 */
571 return;
572
573 default:
574 barf("evacuate(static): strange closure type %d", (int)(info->type));
575 }
576 }
577
578 bd = Bdescr((P_)q);
579
580 if ((bd->flags & (BF_LARGE | BF_MARKED | BF_EVACUATED | BF_COMPACT)) != 0) {
581 // pointer into to-space: just return it. It might be a pointer
582 // into a generation that we aren't collecting (> N), or it
583 // might just be a pointer into to-space. The latter doesn't
584 // happen often, but allowing it makes certain things a bit
585 // easier; e.g. scavenging an object is idempotent, so it's OK to
586 // have an object on the mutable list multiple times.
587 if (bd->flags & BF_EVACUATED) {
588 // We aren't copying this object, so we have to check
589 // whether it is already in the target generation. (this is
590 // the write barrier).
591 if (bd->gen_no < gct->evac_gen_no) {
592 gct->failed_to_evac = true;
593 TICK_GC_FAILED_PROMOTION();
594 }
595 return;
596 }
597
598 // Check for compact before checking for large, this allows doing the
599 // right thing for objects that are half way in the middle of the first
600 // block of a compact (and would be treated as large objects even though
601 // they are not)
602 if (bd->flags & BF_COMPACT) {
603 evacuate_compact((P_)q);
604 return;
605 }
606
607 /* evacuate large objects by re-linking them onto a different list.
608 */
609 if (bd->flags & BF_LARGE) {
610 evacuate_large((P_)q);
611 return;
612 }
613
614 /* If the object is in a gen that we're compacting, then we
615 * need to use an alternative evacuate procedure.
616 */
617 if (!is_marked((P_)q,bd)) {
618 mark((P_)q,bd);
619 push_mark_stack((P_)q);
620 }
621 return;
622 }
623
624 gen_no = bd->dest_no;
625
626 info = q->header.info;
627 if (IS_FORWARDING_PTR(info))
628 {
629 /* Already evacuated, just return the forwarding address.
630 * HOWEVER: if the requested destination generation (gct->evac_gen) is
631 * older than the actual generation (because the object was
632 * already evacuated to a younger generation) then we have to
633 * set the gct->failed_to_evac flag to indicate that we couldn't
634 * manage to promote the object to the desired generation.
635 */
636 /*
637 * Optimisation: the check is fairly expensive, but we can often
638 * shortcut it if either the required generation is 0, or the
639 * current object (the EVACUATED) is in a high enough generation.
640 * We know that an EVACUATED always points to an object in the
641 * same or an older generation. gen is the lowest generation that the
642 * current object would be evacuated to, so we only do the full
643 * check if gen is too low.
644 */
645 StgClosure *e = (StgClosure*)UN_FORWARDING_PTR(info);
646 *p = TAG_CLOSURE(tag,e);
647 if (gen_no < gct->evac_gen_no) { // optimisation
648 if (Bdescr((P_)e)->gen_no < gct->evac_gen_no) {
649 gct->failed_to_evac = true;
650 TICK_GC_FAILED_PROMOTION();
651 }
652 }
653 return;
654 }
655
656 switch (INFO_PTR_TO_STRUCT(info)->type) {
657
658 case WHITEHOLE:
659 goto loop;
660
661 // For ints and chars of low value, save space by replacing references to
662 // these with closures with references to common, shared ones in the RTS.
663 //
664 // * Except when compiling into Windows DLLs which don't support cross-package
665 // data references very well.
666 //
667 case CONSTR_0_1:
668 {
669 #if defined(COMPILING_WINDOWS_DLL)
670 copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen_no,tag);
671 #else
672 StgWord w = (StgWord)q->payload[0];
673 if (info == Czh_con_info &&
674 // unsigned, so always true: (StgChar)w >= MIN_CHARLIKE &&
675 (StgChar)w <= MAX_CHARLIKE) {
676 *p = TAG_CLOSURE(tag,
677 (StgClosure *)CHARLIKE_CLOSURE((StgChar)w)
678 );
679 }
680 else if (info == Izh_con_info &&
681 (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
682 *p = TAG_CLOSURE(tag,
683 (StgClosure *)INTLIKE_CLOSURE((StgInt)w)
684 );
685 }
686 else {
687 copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen_no,tag);
688 }
689 #endif
690 return;
691 }
692
693 case FUN_0_1:
694 case FUN_1_0:
695 case CONSTR_1_0:
696 copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen_no,tag);
697 return;
698
699 case THUNK_1_0:
700 case THUNK_0_1:
701 copy(p,info,q,sizeofW(StgThunk)+1,gen_no);
702 return;
703
704 case THUNK_1_1:
705 case THUNK_2_0:
706 case THUNK_0_2:
707 copy(p,info,q,sizeofW(StgThunk)+2,gen_no);
708 return;
709
710 case FUN_1_1:
711 case FUN_2_0:
712 case FUN_0_2:
713 case CONSTR_1_1:
714 case CONSTR_2_0:
715 copy_tag_nolock(p,info,q,sizeofW(StgHeader)+2,gen_no,tag);
716 return;
717
718 case CONSTR_0_2:
719 copy_tag_nolock(p,info,q,sizeofW(StgHeader)+2,gen_no,tag);
720 return;
721
722 case THUNK:
723 copy(p,info,q,thunk_sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no);
724 return;
725
726 case FUN:
727 case CONSTR:
728 case CONSTR_NOCAF:
729 copy_tag_nolock(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no,tag);
730 return;
731
732 case BLACKHOLE:
733 {
734 StgClosure *r;
735 const StgInfoTable *i;
736 r = ((StgInd*)q)->indirectee;
737 if (GET_CLOSURE_TAG(r) == 0) {
738 i = r->header.info;
739 if (IS_FORWARDING_PTR(i)) {
740 r = (StgClosure *)UN_FORWARDING_PTR(i);
741 i = r->header.info;
742 }
743 if (i == &stg_TSO_info
744 || i == &stg_WHITEHOLE_info
745 || i == &stg_BLOCKING_QUEUE_CLEAN_info
746 || i == &stg_BLOCKING_QUEUE_DIRTY_info) {
747 copy(p,info,q,sizeofW(StgInd),gen_no);
748 return;
749 }
750 // Note [BLACKHOLE pointing to IND]
751 //
752 // BLOCKING_QUEUE can be overwritten by IND (see
753 // wakeBlockingQueue()). However, when this happens we must
754 // be updating the BLACKHOLE, so the BLACKHOLE's indirectee
755 // should now point to the value.
756 //
757 // The mutator might observe an inconsistent state, because
758 // the writes are happening in another thread, so it's
759 // possible for the mutator to follow an indirectee and find
760 // an IND. But this should never happen in the GC, because
761 // the mutators are all stopped and the writes have
762 // completed.
763 ASSERT(i != &stg_IND_info);
764 }
765 q = r;
766 *p = r;
767 goto loop;
768 }
769
770 case MUT_VAR_CLEAN:
771 case MUT_VAR_DIRTY:
772 case MVAR_CLEAN:
773 case MVAR_DIRTY:
774 case TVAR:
775 case BLOCKING_QUEUE:
776 case WEAK:
777 case PRIM:
778 case MUT_PRIM:
779 copy(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no);
780 return;
781
782 case BCO:
783 copy(p,info,q,bco_sizeW((StgBCO *)q),gen_no);
784 return;
785
786 case THUNK_SELECTOR:
787 eval_thunk_selector(p, (StgSelector *)q, true);
788 return;
789
790 case IND:
791 // follow chains of indirections, don't evacuate them
792 q = ((StgInd*)q)->indirectee;
793 *p = q;
794 goto loop;
795
796 case RET_BCO:
797 case RET_SMALL:
798 case RET_BIG:
799 case UPDATE_FRAME:
800 case UNDERFLOW_FRAME:
801 case STOP_FRAME:
802 case CATCH_FRAME:
803 case CATCH_STM_FRAME:
804 case CATCH_RETRY_FRAME:
805 case ATOMICALLY_FRAME:
806 // shouldn't see these
807 barf("evacuate: stack frame at %p\n", q);
808
809 case PAP:
810 copy(p,info,q,pap_sizeW((StgPAP*)q),gen_no);
811 return;
812
813 case AP:
814 copy(p,info,q,ap_sizeW((StgAP*)q),gen_no);
815 return;
816
817 case AP_STACK:
818 copy(p,info,q,ap_stack_sizeW((StgAP_STACK*)q),gen_no);
819 return;
820
821 case ARR_WORDS:
822 // just copy the block
823 copy(p,info,q,arr_words_sizeW((StgArrBytes *)q),gen_no);
824 return;
825
826 case MUT_ARR_PTRS_CLEAN:
827 case MUT_ARR_PTRS_DIRTY:
828 case MUT_ARR_PTRS_FROZEN:
829 case MUT_ARR_PTRS_FROZEN0:
830 // just copy the block
831 copy(p,info,q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),gen_no);
832 return;
833
834 case SMALL_MUT_ARR_PTRS_CLEAN:
835 case SMALL_MUT_ARR_PTRS_DIRTY:
836 case SMALL_MUT_ARR_PTRS_FROZEN:
837 case SMALL_MUT_ARR_PTRS_FROZEN0:
838 // just copy the block
839 copy(p,info,q,small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs *)q),gen_no);
840 return;
841
842 case TSO:
843 copy(p,info,q,sizeofW(StgTSO),gen_no);
844 return;
845
846 case STACK:
847 {
848 StgStack *stack = (StgStack *)q;
849
850 /* To evacuate a small STACK, we need to adjust the stack pointer
851 */
852 {
853 StgStack *new_stack;
854 StgPtr r, s;
855 bool mine;
856
857 mine = copyPart(p,(StgClosure *)stack, stack_sizeW(stack),
858 sizeofW(StgStack), gen_no);
859 if (mine) {
860 new_stack = (StgStack *)*p;
861 move_STACK(stack, new_stack);
862 for (r = stack->sp, s = new_stack->sp;
863 r < stack->stack + stack->stack_size;) {
864 *s++ = *r++;
865 }
866 }
867 return;
868 }
869 }
870
871 case TREC_CHUNK:
872 copy(p,info,q,sizeofW(StgTRecChunk),gen_no);
873 return;
874
875 default:
876 barf("evacuate: strange closure type %d", (int)(INFO_PTR_TO_STRUCT(info)->type));
877 }
878
879 barf("evacuate");
880 }
881
882 /* -----------------------------------------------------------------------------
883 Evacuate a pointer that is guaranteed to point to a BLACKHOLE.
884
885 This is used for evacuating the updatee of an update frame on the stack. We
886 want to copy the blackhole even if it has been updated by another thread and
887 is now an indirection, because the original update frame still needs to
888 update it.
889
890 See also Note [upd-black-hole] in sm/Scav.c.
891 -------------------------------------------------------------------------- */
892
893 void
894 evacuate_BLACKHOLE(StgClosure **p)
895 {
896 bdescr *bd;
897 uint32_t gen_no;
898 StgClosure *q;
899 const StgInfoTable *info;
900 q = *p;
901
902 // closure is required to be a heap-allocated BLACKHOLE
903 ASSERT(HEAP_ALLOCED_GC(q));
904 ASSERT(GET_CLOSURE_TAG(q) == 0);
905
906 bd = Bdescr((P_)q);
907
908 // blackholes can't be in a compact
909 ASSERT((bd->flags & BF_COMPACT) == 0);
910
911 // blackholes *can* be in a large object: when raiseAsync() creates an
912 // AP_STACK the payload might be large enough to create a large object.
913 // See #14497.
914 if (bd->flags & BF_LARGE) {
915 evacuate_large((P_)q);
916 return;
917 }
918 if (bd->flags & BF_EVACUATED) {
919 if (bd->gen_no < gct->evac_gen_no) {
920 gct->failed_to_evac = true;
921 TICK_GC_FAILED_PROMOTION();
922 }
923 return;
924 }
925 if (bd->flags & BF_MARKED) {
926 if (!is_marked((P_)q,bd)) {
927 mark((P_)q,bd);
928 push_mark_stack((P_)q);
929 }
930 return;
931 }
932 gen_no = bd->dest_no;
933 info = q->header.info;
934 if (IS_FORWARDING_PTR(info))
935 {
936 StgClosure *e = (StgClosure*)UN_FORWARDING_PTR(info);
937 *p = e;
938 if (gen_no < gct->evac_gen_no) { // optimisation
939 if (Bdescr((P_)e)->gen_no < gct->evac_gen_no) {
940 gct->failed_to_evac = true;
941 TICK_GC_FAILED_PROMOTION();
942 }
943 }
944 return;
945 }
946
947 ASSERT(INFO_PTR_TO_STRUCT(info)->type == BLACKHOLE);
948 copy(p,info,q,sizeofW(StgInd),gen_no);
949 }
950
951 /* -----------------------------------------------------------------------------
952 Evaluate a THUNK_SELECTOR if possible.
953
954 p points to a THUNK_SELECTOR that we want to evaluate. The
955 result of "evaluating" it will be evacuated and a pointer to the
956 to-space closure will be returned.
957
958 If the THUNK_SELECTOR could not be evaluated (its selectee is still
959 a THUNK, for example), then the THUNK_SELECTOR itself will be
960 evacuated.
961 -------------------------------------------------------------------------- */
962 static void
963 unchain_thunk_selectors(StgSelector *p, StgClosure *val)
964 {
965 StgSelector *prev;
966
967 prev = NULL;
968 while (p)
969 {
970 ASSERT(p->header.info == &stg_WHITEHOLE_info);
971 // val must be in to-space. Not always: when we recursively
972 // invoke eval_thunk_selector(), the recursive calls will not
973 // evacuate the value (because we want to select on the value,
974 // not evacuate it), so in this case val is in from-space.
975 // ASSERT(!HEAP_ALLOCED_GC(val) || Bdescr((P_)val)->gen_no > N || (Bdescr((P_)val)->flags & BF_EVACUATED));
976
977 prev = (StgSelector*)((StgClosure *)p)->payload[0];
978
979 // Update the THUNK_SELECTOR with an indirection to the
980 // value. The value is still in from-space at this stage.
981 //
982 // (old note: Why not do upd_evacuee(q,p)? Because we have an
983 // invariant that an EVACUATED closure always points to an
984 // object in the same or an older generation (required by
985 // the short-cut test in the EVACUATED case, below).
986 if ((StgClosure *)p == val) {
987 // must be a loop; just leave a BLACKHOLE in place. This
988 // can happen when we have a chain of selectors that
989 // eventually loops back on itself. We can't leave an
990 // indirection pointing to itself, and we want the program
991 // to deadlock if it ever enters this closure, so
992 // BLACKHOLE is correct.
993
994 // XXX we do not have BLACKHOLEs any more; replace with
995 // a THUNK_SELECTOR again. This will go into a loop if it is
996 // entered, and should result in a NonTermination exception.
997 ((StgThunk *)p)->payload[0] = val;
998 write_barrier();
999 SET_INFO((StgClosure *)p, &stg_sel_0_upd_info);
1000 } else {
1001 ((StgInd *)p)->indirectee = val;
1002 write_barrier();
1003 SET_INFO((StgClosure *)p, &stg_IND_info);
1004 }
1005
1006 // For the purposes of LDV profiling, we have created an
1007 // indirection.
1008 LDV_RECORD_CREATE(p);
1009
1010 p = prev;
1011 }
1012 }
1013
1014 static void
1015 eval_thunk_selector (StgClosure **q, StgSelector * p, bool evac)
1016 // NB. for legacy reasons, p & q are swapped around :(
1017 {
1018 uint32_t field;
1019 StgInfoTable *info;
1020 StgWord info_ptr;
1021 StgClosure *selectee;
1022 StgSelector *prev_thunk_selector;
1023 bdescr *bd;
1024 StgClosure *val;
1025
1026 prev_thunk_selector = NULL;
1027 // this is a chain of THUNK_SELECTORs that we are going to update
1028 // to point to the value of the current THUNK_SELECTOR. Each
1029 // closure on the chain is a WHITEHOLE, and points to the next in the
1030 // chain with payload[0].
1031
1032 selector_chain:
1033
1034 bd = Bdescr((StgPtr)p);
1035 if (HEAP_ALLOCED_GC(p)) {
1036 // If the THUNK_SELECTOR is in to-space or in a generation that we
1037 // are not collecting, then bale out early. We won't be able to
1038 // save any space in any case, and updating with an indirection is
1039 // trickier in a non-collected gen: we would have to update the
1040 // mutable list.
1041 if (bd->flags & BF_EVACUATED) {
1042 unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p);
1043 *q = (StgClosure *)p;
1044 // shortcut, behave as for: if (evac) evacuate(q);
1045 if (evac && bd->gen_no < gct->evac_gen_no) {
1046 gct->failed_to_evac = true;
1047 TICK_GC_FAILED_PROMOTION();
1048 }
1049 return;
1050 }
1051 // we don't update THUNK_SELECTORS in the compacted
1052 // generation, because compaction does not remove the INDs
1053 // that result, this causes confusion later
1054 // (scavenge_mark_stack doesn't deal with IND). BEWARE! This
1055 // bit is very tricky to get right. If you make changes
1056 // around here, test by compiling stage 3 with +RTS -c -RTS.
1057 if (bd->flags & BF_MARKED) {
1058 // must call evacuate() to mark this closure if evac==true
1059 *q = (StgClosure *)p;
1060 if (evac) evacuate(q);
1061 unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p);
1062 return;
1063 }
1064 }
1065
1066
1067 // WHITEHOLE the selector thunk, since it is now under evaluation.
1068 // This is important to stop us going into an infinite loop if
1069 // this selector thunk eventually refers to itself.
1070 #if defined(THREADED_RTS)
1071 // In threaded mode, we'll use WHITEHOLE to lock the selector
1072 // thunk while we evaluate it.
1073 {
1074 while(true) {
1075 info_ptr = xchg((StgPtr)&p->header.info, (W_)&stg_WHITEHOLE_info);
1076 if (info_ptr != (W_)&stg_WHITEHOLE_info) { break; }
1077 #if defined(PROF_SPIN)
1078 ++whitehole_gc_spin;
1079 #endif
1080 busy_wait_nop();
1081 }
1082
1083 // make sure someone else didn't get here first...
1084 if (IS_FORWARDING_PTR(info_ptr) ||
1085 INFO_PTR_TO_STRUCT((StgInfoTable *)info_ptr)->type != THUNK_SELECTOR) {
1086 // v. tricky now. The THUNK_SELECTOR has been evacuated
1087 // by another thread, and is now either a forwarding ptr or IND.
1088 // We need to extract ourselves from the current situation
1089 // as cleanly as possible.
1090 // - unlock the closure
1091 // - update *q, we may have done *some* evaluation
1092 // - if evac, we need to call evacuate(), because we
1093 // need the write-barrier stuff.
1094 // - undo the chain we've built to point to p.
1095 SET_INFO((StgClosure *)p, (const StgInfoTable *)info_ptr);
1096 *q = (StgClosure *)p;
1097 if (evac) evacuate(q);
1098 unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p);
1099 return;
1100 }
1101 }
1102 #else
1103 // Save the real info pointer (NOTE: not the same as get_itbl()).
1104 info_ptr = (StgWord)p->header.info;
1105 SET_INFO((StgClosure *)p,&stg_WHITEHOLE_info);
1106 #endif
1107
1108 field = INFO_PTR_TO_STRUCT((StgInfoTable *)info_ptr)->layout.selector_offset;
1109
1110 // The selectee might be a constructor closure,
1111 // so we untag the pointer.
1112 selectee = UNTAG_CLOSURE(p->selectee);
1113
1114 selector_loop:
1115 // selectee now points to the closure that we're trying to select
1116 // a field from. It may or may not be in to-space: we try not to
1117 // end up in to-space, but it's impractical to avoid it in
1118 // general. The compacting GC scatters to-space pointers in
1119 // from-space during marking, for example. We rely on the property
1120 // that evacuate() doesn't mind if it gets passed a to-space pointer.
1121
1122 info = (StgInfoTable*)selectee->header.info;
1123
1124 if (IS_FORWARDING_PTR(info)) {
1125 // We don't follow pointers into to-space; the constructor
1126 // has already been evacuated, so we won't save any space
1127 // leaks by evaluating this selector thunk anyhow.
1128 goto bale_out;
1129 }
1130
1131 info = INFO_PTR_TO_STRUCT(info);
1132 switch (info->type) {
1133 case WHITEHOLE:
1134 goto bale_out; // about to be evacuated by another thread (or a loop).
1135
1136 case CONSTR:
1137 case CONSTR_1_0:
1138 case CONSTR_0_1:
1139 case CONSTR_2_0:
1140 case CONSTR_1_1:
1141 case CONSTR_0_2:
1142 case CONSTR_NOCAF:
1143 {
1144 // check that the size is in range
1145 ASSERT(field < (StgWord32)(info->layout.payload.ptrs +
1146 info->layout.payload.nptrs));
1147
1148 // Select the right field from the constructor
1149 val = selectee->payload[field];
1150
1151 #if defined(PROFILING)
1152 // For the purposes of LDV profiling, we have destroyed
1153 // the original selector thunk, p.
1154 if (era > 0) {
1155 // Only modify the info pointer when LDV profiling is
1156 // enabled. Note that this is incompatible with parallel GC,
1157 // because it would allow other threads to start evaluating
1158 // the same selector thunk.
1159 SET_INFO((StgClosure*)p, (StgInfoTable *)info_ptr);
1160 OVERWRITING_CLOSURE((StgClosure*)p);
1161 SET_INFO((StgClosure*)p, &stg_WHITEHOLE_info);
1162 }
1163 #endif
1164
1165 // the closure in val is now the "value" of the
1166 // THUNK_SELECTOR in p. However, val may itself be a
1167 // THUNK_SELECTOR, in which case we want to continue
1168 // evaluating until we find the real value, and then
1169 // update the whole chain to point to the value.
1170 val_loop:
1171 info_ptr = (StgWord)UNTAG_CLOSURE(val)->header.info;
1172 if (!IS_FORWARDING_PTR(info_ptr))
1173 {
1174 info = INFO_PTR_TO_STRUCT((StgInfoTable *)info_ptr);
1175 switch (info->type) {
1176 case IND:
1177 case IND_STATIC:
1178 val = ((StgInd *)val)->indirectee;
1179 goto val_loop;
1180 case THUNK_SELECTOR:
1181 ((StgClosure*)p)->payload[0] = (StgClosure *)prev_thunk_selector;
1182 prev_thunk_selector = p;
1183 p = (StgSelector*)val;
1184 goto selector_chain;
1185 default:
1186 break;
1187 }
1188 }
1189 ((StgClosure*)p)->payload[0] = (StgClosure *)prev_thunk_selector;
1190 prev_thunk_selector = p;
1191
1192 *q = val;
1193
1194 // update the other selectors in the chain *before*
1195 // evacuating the value. This is necessary in the case
1196 // where the value turns out to be one of the selectors
1197 // in the chain (i.e. we have a loop), and evacuating it
1198 // would corrupt the chain.
1199 unchain_thunk_selectors(prev_thunk_selector, val);
1200
1201 // evacuate() cannot recurse through
1202 // eval_thunk_selector(), because we know val is not
1203 // a THUNK_SELECTOR.
1204 if (evac) evacuate(q);
1205 return;
1206 }
1207
1208 case IND:
1209 case IND_STATIC:
1210 // Again, we might need to untag a constructor.
1211 selectee = UNTAG_CLOSURE( ((StgInd *)selectee)->indirectee );
1212 goto selector_loop;
1213
1214 case BLACKHOLE:
1215 {
1216 StgClosure *r;
1217 const StgInfoTable *i;
1218 r = ((StgInd*)selectee)->indirectee;
1219
1220 // establish whether this BH has been updated, and is now an
1221 // indirection, as in evacuate().
1222 if (GET_CLOSURE_TAG(r) == 0) {
1223 i = r->header.info;
1224 if (IS_FORWARDING_PTR(i)) {
1225 r = (StgClosure *)UN_FORWARDING_PTR(i);
1226 i = r->header.info;
1227 }
1228 if (i == &stg_TSO_info
1229 || i == &stg_WHITEHOLE_info
1230 || i == &stg_BLOCKING_QUEUE_CLEAN_info
1231 || i == &stg_BLOCKING_QUEUE_DIRTY_info) {
1232 goto bale_out;
1233 }
1234 ASSERT(i != &stg_IND_info);
1235 }
1236
1237 selectee = UNTAG_CLOSURE( ((StgInd *)selectee)->indirectee );
1238 goto selector_loop;
1239 }
1240
1241 case THUNK_SELECTOR:
1242 {
1243 StgClosure *val;
1244
1245 // recursively evaluate this selector. We don't want to
1246 // recurse indefinitely, so we impose a depth bound.
1247 if (gct->thunk_selector_depth >= MAX_THUNK_SELECTOR_DEPTH) {
1248 goto bale_out;
1249 }
1250
1251 gct->thunk_selector_depth++;
1252 // false says "don't evacuate the result". It will,
1253 // however, update any THUNK_SELECTORs that are evaluated
1254 // along the way.
1255 eval_thunk_selector(&val, (StgSelector*)selectee, false);
1256 gct->thunk_selector_depth--;
1257
1258 // did we actually manage to evaluate it?
1259 if (val == selectee) goto bale_out;
1260
1261 // Of course this pointer might be tagged...
1262 selectee = UNTAG_CLOSURE(val);
1263 goto selector_loop;
1264 }
1265
1266 case AP:
1267 case AP_STACK:
1268 case THUNK:
1269 case THUNK_1_0:
1270 case THUNK_0_1:
1271 case THUNK_2_0:
1272 case THUNK_1_1:
1273 case THUNK_0_2:
1274 case THUNK_STATIC:
1275 // not evaluated yet
1276 goto bale_out;
1277
1278 default:
1279 barf("eval_thunk_selector: strange selectee %d",
1280 (int)(info->type));
1281 }
1282
1283 bale_out:
1284 // We didn't manage to evaluate this thunk; restore the old info
1285 // pointer. But don't forget: we still need to evacuate the thunk itself.
1286 SET_INFO((StgClosure *)p, (const StgInfoTable *)info_ptr);
1287 // THREADED_RTS: we just unlocked the thunk, so another thread
1288 // might get in and update it. copy() will lock it again and
1289 // check whether it was updated in the meantime.
1290 *q = (StgClosure *)p;
1291 if (evac) {
1292 copy(q,(const StgInfoTable *)info_ptr,(StgClosure *)p,THUNK_SELECTOR_sizeW(),bd->dest_no);
1293 }
1294 unchain_thunk_selectors(prev_thunk_selector, *q);
1295 return;
1296 }