bb54c7efc35ddf9cadb28c37c5aa74759ed96b7e
[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_bitmap != 0) {
540 evacuate_static_object(THUNK_STATIC_LINK((StgClosure *)q), q);
541 }
542 return;
543
544 case FUN_STATIC:
545 if (info->srt_bitmap != 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 ASSERT(i != &stg_IND_info);
751 }
752 q = r;
753 *p = r;
754 goto loop;
755 }
756
757 case MUT_VAR_CLEAN:
758 case MUT_VAR_DIRTY:
759 case MVAR_CLEAN:
760 case MVAR_DIRTY:
761 case TVAR:
762 case BLOCKING_QUEUE:
763 case WEAK:
764 case PRIM:
765 case MUT_PRIM:
766 copy(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no);
767 return;
768
769 case BCO:
770 copy(p,info,q,bco_sizeW((StgBCO *)q),gen_no);
771 return;
772
773 case THUNK_SELECTOR:
774 eval_thunk_selector(p, (StgSelector *)q, true);
775 return;
776
777 case IND:
778 // follow chains of indirections, don't evacuate them
779 q = ((StgInd*)q)->indirectee;
780 *p = q;
781 goto loop;
782
783 case RET_BCO:
784 case RET_SMALL:
785 case RET_BIG:
786 case UPDATE_FRAME:
787 case UNDERFLOW_FRAME:
788 case STOP_FRAME:
789 case CATCH_FRAME:
790 case CATCH_STM_FRAME:
791 case CATCH_RETRY_FRAME:
792 case ATOMICALLY_FRAME:
793 // shouldn't see these
794 barf("evacuate: stack frame at %p\n", q);
795
796 case PAP:
797 copy(p,info,q,pap_sizeW((StgPAP*)q),gen_no);
798 return;
799
800 case AP:
801 copy(p,info,q,ap_sizeW((StgAP*)q),gen_no);
802 return;
803
804 case AP_STACK:
805 copy(p,info,q,ap_stack_sizeW((StgAP_STACK*)q),gen_no);
806 return;
807
808 case ARR_WORDS:
809 // just copy the block
810 copy(p,info,q,arr_words_sizeW((StgArrBytes *)q),gen_no);
811 return;
812
813 case MUT_ARR_PTRS_CLEAN:
814 case MUT_ARR_PTRS_DIRTY:
815 case MUT_ARR_PTRS_FROZEN:
816 case MUT_ARR_PTRS_FROZEN0:
817 // just copy the block
818 copy(p,info,q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),gen_no);
819 return;
820
821 case SMALL_MUT_ARR_PTRS_CLEAN:
822 case SMALL_MUT_ARR_PTRS_DIRTY:
823 case SMALL_MUT_ARR_PTRS_FROZEN:
824 case SMALL_MUT_ARR_PTRS_FROZEN0:
825 // just copy the block
826 copy(p,info,q,small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs *)q),gen_no);
827 return;
828
829 case TSO:
830 copy(p,info,q,sizeofW(StgTSO),gen_no);
831 return;
832
833 case STACK:
834 {
835 StgStack *stack = (StgStack *)q;
836
837 /* To evacuate a small STACK, we need to adjust the stack pointer
838 */
839 {
840 StgStack *new_stack;
841 StgPtr r, s;
842 bool mine;
843
844 mine = copyPart(p,(StgClosure *)stack, stack_sizeW(stack),
845 sizeofW(StgStack), gen_no);
846 if (mine) {
847 new_stack = (StgStack *)*p;
848 move_STACK(stack, new_stack);
849 for (r = stack->sp, s = new_stack->sp;
850 r < stack->stack + stack->stack_size;) {
851 *s++ = *r++;
852 }
853 }
854 return;
855 }
856 }
857
858 case TREC_CHUNK:
859 copy(p,info,q,sizeofW(StgTRecChunk),gen_no);
860 return;
861
862 default:
863 barf("evacuate: strange closure type %d", (int)(INFO_PTR_TO_STRUCT(info)->type));
864 }
865
866 barf("evacuate");
867 }
868
869 /* -----------------------------------------------------------------------------
870 Evacuate a pointer that is guaranteed to point to a BLACKHOLE.
871
872 This is used for evacuating the updatee of an update frame on the stack. We
873 want to copy the blackhole even if it has been updated by another thread and
874 is now an indirection, because the original update frame still needs to
875 update it.
876
877 See also Note [upd-black-hole] in sm/Scav.c.
878 -------------------------------------------------------------------------- */
879
880 void
881 evacuate_BLACKHOLE(StgClosure **p)
882 {
883 bdescr *bd;
884 uint32_t gen_no;
885 StgClosure *q;
886 const StgInfoTable *info;
887 q = *p;
888
889 // closure is required to be a heap-allocated BLACKHOLE
890 ASSERT(HEAP_ALLOCED_GC(q));
891 ASSERT(GET_CLOSURE_TAG(q) == 0);
892
893 bd = Bdescr((P_)q);
894
895 // blackholes can't be in a compact
896 ASSERT((bd->flags & BF_COMPACT) == 0);
897
898 // blackholes *can* be in a large object: when raiseAsync() creates an
899 // AP_STACK the payload might be large enough to create a large object.
900 // See #14497.
901 if (bd->flags & BF_LARGE) {
902 evacuate_large((P_)q);
903 return;
904 }
905 if (bd->flags & BF_EVACUATED) {
906 if (bd->gen_no < gct->evac_gen_no) {
907 gct->failed_to_evac = true;
908 TICK_GC_FAILED_PROMOTION();
909 }
910 return;
911 }
912 if (bd->flags & BF_MARKED) {
913 if (!is_marked((P_)q,bd)) {
914 mark((P_)q,bd);
915 push_mark_stack((P_)q);
916 }
917 return;
918 }
919 gen_no = bd->dest_no;
920 info = q->header.info;
921 if (IS_FORWARDING_PTR(info))
922 {
923 StgClosure *e = (StgClosure*)UN_FORWARDING_PTR(info);
924 *p = e;
925 if (gen_no < gct->evac_gen_no) { // optimisation
926 if (Bdescr((P_)e)->gen_no < gct->evac_gen_no) {
927 gct->failed_to_evac = true;
928 TICK_GC_FAILED_PROMOTION();
929 }
930 }
931 return;
932 }
933
934 ASSERT(INFO_PTR_TO_STRUCT(info)->type == BLACKHOLE);
935 copy(p,info,q,sizeofW(StgInd),gen_no);
936 }
937
938 /* -----------------------------------------------------------------------------
939 Evaluate a THUNK_SELECTOR if possible.
940
941 p points to a THUNK_SELECTOR that we want to evaluate. The
942 result of "evaluating" it will be evacuated and a pointer to the
943 to-space closure will be returned.
944
945 If the THUNK_SELECTOR could not be evaluated (its selectee is still
946 a THUNK, for example), then the THUNK_SELECTOR itself will be
947 evacuated.
948 -------------------------------------------------------------------------- */
949 static void
950 unchain_thunk_selectors(StgSelector *p, StgClosure *val)
951 {
952 StgSelector *prev;
953
954 prev = NULL;
955 while (p)
956 {
957 ASSERT(p->header.info == &stg_WHITEHOLE_info);
958 // val must be in to-space. Not always: when we recursively
959 // invoke eval_thunk_selector(), the recursive calls will not
960 // evacuate the value (because we want to select on the value,
961 // not evacuate it), so in this case val is in from-space.
962 // ASSERT(!HEAP_ALLOCED_GC(val) || Bdescr((P_)val)->gen_no > N || (Bdescr((P_)val)->flags & BF_EVACUATED));
963
964 prev = (StgSelector*)((StgClosure *)p)->payload[0];
965
966 // Update the THUNK_SELECTOR with an indirection to the
967 // value. The value is still in from-space at this stage.
968 //
969 // (old note: Why not do upd_evacuee(q,p)? Because we have an
970 // invariant that an EVACUATED closure always points to an
971 // object in the same or an older generation (required by
972 // the short-cut test in the EVACUATED case, below).
973 if ((StgClosure *)p == val) {
974 // must be a loop; just leave a BLACKHOLE in place. This
975 // can happen when we have a chain of selectors that
976 // eventually loops back on itself. We can't leave an
977 // indirection pointing to itself, and we want the program
978 // to deadlock if it ever enters this closure, so
979 // BLACKHOLE is correct.
980
981 // XXX we do not have BLACKHOLEs any more; replace with
982 // a THUNK_SELECTOR again. This will go into a loop if it is
983 // entered, and should result in a NonTermination exception.
984 ((StgThunk *)p)->payload[0] = val;
985 write_barrier();
986 SET_INFO((StgClosure *)p, &stg_sel_0_upd_info);
987 } else {
988 ((StgInd *)p)->indirectee = val;
989 write_barrier();
990 SET_INFO((StgClosure *)p, &stg_IND_info);
991 }
992
993 // For the purposes of LDV profiling, we have created an
994 // indirection.
995 LDV_RECORD_CREATE(p);
996
997 p = prev;
998 }
999 }
1000
1001 static void
1002 eval_thunk_selector (StgClosure **q, StgSelector * p, bool evac)
1003 // NB. for legacy reasons, p & q are swapped around :(
1004 {
1005 uint32_t field;
1006 StgInfoTable *info;
1007 StgWord info_ptr;
1008 StgClosure *selectee;
1009 StgSelector *prev_thunk_selector;
1010 bdescr *bd;
1011 StgClosure *val;
1012
1013 prev_thunk_selector = NULL;
1014 // this is a chain of THUNK_SELECTORs that we are going to update
1015 // to point to the value of the current THUNK_SELECTOR. Each
1016 // closure on the chain is a WHITEHOLE, and points to the next in the
1017 // chain with payload[0].
1018
1019 selector_chain:
1020
1021 bd = Bdescr((StgPtr)p);
1022 if (HEAP_ALLOCED_GC(p)) {
1023 // If the THUNK_SELECTOR is in to-space or in a generation that we
1024 // are not collecting, then bale out early. We won't be able to
1025 // save any space in any case, and updating with an indirection is
1026 // trickier in a non-collected gen: we would have to update the
1027 // mutable list.
1028 if (bd->flags & BF_EVACUATED) {
1029 unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p);
1030 *q = (StgClosure *)p;
1031 // shortcut, behave as for: if (evac) evacuate(q);
1032 if (evac && bd->gen_no < gct->evac_gen_no) {
1033 gct->failed_to_evac = true;
1034 TICK_GC_FAILED_PROMOTION();
1035 }
1036 return;
1037 }
1038 // we don't update THUNK_SELECTORS in the compacted
1039 // generation, because compaction does not remove the INDs
1040 // that result, this causes confusion later
1041 // (scavenge_mark_stack doesn't deal with IND). BEWARE! This
1042 // bit is very tricky to get right. If you make changes
1043 // around here, test by compiling stage 3 with +RTS -c -RTS.
1044 if (bd->flags & BF_MARKED) {
1045 // must call evacuate() to mark this closure if evac==true
1046 *q = (StgClosure *)p;
1047 if (evac) evacuate(q);
1048 unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p);
1049 return;
1050 }
1051 }
1052
1053
1054 // WHITEHOLE the selector thunk, since it is now under evaluation.
1055 // This is important to stop us going into an infinite loop if
1056 // this selector thunk eventually refers to itself.
1057 #if defined(THREADED_RTS)
1058 // In threaded mode, we'll use WHITEHOLE to lock the selector
1059 // thunk while we evaluate it.
1060 {
1061 do {
1062 info_ptr = xchg((StgPtr)&p->header.info, (W_)&stg_WHITEHOLE_info);
1063 } while (info_ptr == (W_)&stg_WHITEHOLE_info);
1064
1065 // make sure someone else didn't get here first...
1066 if (IS_FORWARDING_PTR(info_ptr) ||
1067 INFO_PTR_TO_STRUCT((StgInfoTable *)info_ptr)->type != THUNK_SELECTOR) {
1068 // v. tricky now. The THUNK_SELECTOR has been evacuated
1069 // by another thread, and is now either a forwarding ptr or IND.
1070 // We need to extract ourselves from the current situation
1071 // as cleanly as possible.
1072 // - unlock the closure
1073 // - update *q, we may have done *some* evaluation
1074 // - if evac, we need to call evacuate(), because we
1075 // need the write-barrier stuff.
1076 // - undo the chain we've built to point to p.
1077 SET_INFO((StgClosure *)p, (const StgInfoTable *)info_ptr);
1078 *q = (StgClosure *)p;
1079 if (evac) evacuate(q);
1080 unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p);
1081 return;
1082 }
1083 }
1084 #else
1085 // Save the real info pointer (NOTE: not the same as get_itbl()).
1086 info_ptr = (StgWord)p->header.info;
1087 SET_INFO((StgClosure *)p,&stg_WHITEHOLE_info);
1088 #endif
1089
1090 field = INFO_PTR_TO_STRUCT((StgInfoTable *)info_ptr)->layout.selector_offset;
1091
1092 // The selectee might be a constructor closure,
1093 // so we untag the pointer.
1094 selectee = UNTAG_CLOSURE(p->selectee);
1095
1096 selector_loop:
1097 // selectee now points to the closure that we're trying to select
1098 // a field from. It may or may not be in to-space: we try not to
1099 // end up in to-space, but it's impractical to avoid it in
1100 // general. The compacting GC scatters to-space pointers in
1101 // from-space during marking, for example. We rely on the property
1102 // that evacuate() doesn't mind if it gets passed a to-space pointer.
1103
1104 info = (StgInfoTable*)selectee->header.info;
1105
1106 if (IS_FORWARDING_PTR(info)) {
1107 // We don't follow pointers into to-space; the constructor
1108 // has already been evacuated, so we won't save any space
1109 // leaks by evaluating this selector thunk anyhow.
1110 goto bale_out;
1111 }
1112
1113 info = INFO_PTR_TO_STRUCT(info);
1114 switch (info->type) {
1115 case WHITEHOLE:
1116 goto bale_out; // about to be evacuated by another thread (or a loop).
1117
1118 case CONSTR:
1119 case CONSTR_1_0:
1120 case CONSTR_0_1:
1121 case CONSTR_2_0:
1122 case CONSTR_1_1:
1123 case CONSTR_0_2:
1124 case CONSTR_NOCAF:
1125 {
1126 // check that the size is in range
1127 ASSERT(field < (StgWord32)(info->layout.payload.ptrs +
1128 info->layout.payload.nptrs));
1129
1130 // Select the right field from the constructor
1131 val = selectee->payload[field];
1132
1133 #if defined(PROFILING)
1134 // For the purposes of LDV profiling, we have destroyed
1135 // the original selector thunk, p.
1136 if (era > 0) {
1137 // Only modify the info pointer when LDV profiling is
1138 // enabled. Note that this is incompatible with parallel GC,
1139 // because it would allow other threads to start evaluating
1140 // the same selector thunk.
1141 SET_INFO((StgClosure*)p, (StgInfoTable *)info_ptr);
1142 OVERWRITING_CLOSURE((StgClosure*)p);
1143 SET_INFO((StgClosure*)p, &stg_WHITEHOLE_info);
1144 }
1145 #endif
1146
1147 // the closure in val is now the "value" of the
1148 // THUNK_SELECTOR in p. However, val may itself be a
1149 // THUNK_SELECTOR, in which case we want to continue
1150 // evaluating until we find the real value, and then
1151 // update the whole chain to point to the value.
1152 val_loop:
1153 info_ptr = (StgWord)UNTAG_CLOSURE(val)->header.info;
1154 if (!IS_FORWARDING_PTR(info_ptr))
1155 {
1156 info = INFO_PTR_TO_STRUCT((StgInfoTable *)info_ptr);
1157 switch (info->type) {
1158 case IND:
1159 case IND_STATIC:
1160 val = ((StgInd *)val)->indirectee;
1161 goto val_loop;
1162 case THUNK_SELECTOR:
1163 ((StgClosure*)p)->payload[0] = (StgClosure *)prev_thunk_selector;
1164 prev_thunk_selector = p;
1165 p = (StgSelector*)val;
1166 goto selector_chain;
1167 default:
1168 break;
1169 }
1170 }
1171 ((StgClosure*)p)->payload[0] = (StgClosure *)prev_thunk_selector;
1172 prev_thunk_selector = p;
1173
1174 *q = val;
1175
1176 // update the other selectors in the chain *before*
1177 // evacuating the value. This is necessary in the case
1178 // where the value turns out to be one of the selectors
1179 // in the chain (i.e. we have a loop), and evacuating it
1180 // would corrupt the chain.
1181 unchain_thunk_selectors(prev_thunk_selector, val);
1182
1183 // evacuate() cannot recurse through
1184 // eval_thunk_selector(), because we know val is not
1185 // a THUNK_SELECTOR.
1186 if (evac) evacuate(q);
1187 return;
1188 }
1189
1190 case IND:
1191 case IND_STATIC:
1192 // Again, we might need to untag a constructor.
1193 selectee = UNTAG_CLOSURE( ((StgInd *)selectee)->indirectee );
1194 goto selector_loop;
1195
1196 case BLACKHOLE:
1197 {
1198 StgClosure *r;
1199 const StgInfoTable *i;
1200 r = ((StgInd*)selectee)->indirectee;
1201
1202 // establish whether this BH has been updated, and is now an
1203 // indirection, as in evacuate().
1204 if (GET_CLOSURE_TAG(r) == 0) {
1205 i = r->header.info;
1206 if (IS_FORWARDING_PTR(i)) {
1207 r = (StgClosure *)UN_FORWARDING_PTR(i);
1208 i = r->header.info;
1209 }
1210 if (i == &stg_TSO_info
1211 || i == &stg_WHITEHOLE_info
1212 || i == &stg_BLOCKING_QUEUE_CLEAN_info
1213 || i == &stg_BLOCKING_QUEUE_DIRTY_info) {
1214 goto bale_out;
1215 }
1216 ASSERT(i != &stg_IND_info);
1217 }
1218
1219 selectee = UNTAG_CLOSURE( ((StgInd *)selectee)->indirectee );
1220 goto selector_loop;
1221 }
1222
1223 case THUNK_SELECTOR:
1224 {
1225 StgClosure *val;
1226
1227 // recursively evaluate this selector. We don't want to
1228 // recurse indefinitely, so we impose a depth bound.
1229 if (gct->thunk_selector_depth >= MAX_THUNK_SELECTOR_DEPTH) {
1230 goto bale_out;
1231 }
1232
1233 gct->thunk_selector_depth++;
1234 // false says "don't evacuate the result". It will,
1235 // however, update any THUNK_SELECTORs that are evaluated
1236 // along the way.
1237 eval_thunk_selector(&val, (StgSelector*)selectee, false);
1238 gct->thunk_selector_depth--;
1239
1240 // did we actually manage to evaluate it?
1241 if (val == selectee) goto bale_out;
1242
1243 // Of course this pointer might be tagged...
1244 selectee = UNTAG_CLOSURE(val);
1245 goto selector_loop;
1246 }
1247
1248 case AP:
1249 case AP_STACK:
1250 case THUNK:
1251 case THUNK_1_0:
1252 case THUNK_0_1:
1253 case THUNK_2_0:
1254 case THUNK_1_1:
1255 case THUNK_0_2:
1256 case THUNK_STATIC:
1257 // not evaluated yet
1258 goto bale_out;
1259
1260 default:
1261 barf("eval_thunk_selector: strange selectee %d",
1262 (int)(info->type));
1263 }
1264
1265 bale_out:
1266 // We didn't manage to evaluate this thunk; restore the old info
1267 // pointer. But don't forget: we still need to evacuate the thunk itself.
1268 SET_INFO((StgClosure *)p, (const StgInfoTable *)info_ptr);
1269 // THREADED_RTS: we just unlocked the thunk, so another thread
1270 // might get in and update it. copy() will lock it again and
1271 // check whether it was updated in the meantime.
1272 *q = (StgClosure *)p;
1273 if (evac) {
1274 copy(q,(const StgInfoTable *)info_ptr,(StgClosure *)p,THUNK_SELECTOR_sizeW(),bd->dest_no);
1275 }
1276 unchain_thunk_selectors(prev_thunk_selector, *q);
1277 return;
1278 }