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