Remove CONSTR_STATIC
[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:
552 case CONSTR_1_0:
553 case CONSTR_2_0:
554 case CONSTR_1_1:
555 evacuate_static_object(STATIC_LINK(info,(StgClosure *)q), q);
556 return;
557
558 case CONSTR_0_1:
559 case CONSTR_0_2:
560 case CONSTR_NOCAF:
561 /* no need to put these on the static linked list, they don't need
562 * to be scavenged.
563 */
564 return;
565
566 default:
567 barf("evacuate(static): strange closure type %d", (int)(info->type));
568 }
569 }
570
571 bd = Bdescr((P_)q);
572
573 if ((bd->flags & (BF_LARGE | BF_MARKED | BF_EVACUATED | BF_COMPACT)) != 0) {
574 // pointer into to-space: just return it. It might be a pointer
575 // into a generation that we aren't collecting (> N), or it
576 // might just be a pointer into to-space. The latter doesn't
577 // happen often, but allowing it makes certain things a bit
578 // easier; e.g. scavenging an object is idempotent, so it's OK to
579 // have an object on the mutable list multiple times.
580 if (bd->flags & BF_EVACUATED) {
581 // We aren't copying this object, so we have to check
582 // whether it is already in the target generation. (this is
583 // the write barrier).
584 if (bd->gen_no < gct->evac_gen_no) {
585 gct->failed_to_evac = rtsTrue;
586 TICK_GC_FAILED_PROMOTION();
587 }
588 return;
589 }
590
591 // Check for compact before checking for large, this allows doing the
592 // right thing for objects that are half way in the middle of the first
593 // block of a compact (and would be treated as large objects even though
594 // they are not)
595 if (bd->flags & BF_COMPACT) {
596 evacuate_compact((P_)q);
597 return;
598 }
599
600 /* evacuate large objects by re-linking them onto a different list.
601 */
602 if (bd->flags & BF_LARGE) {
603 evacuate_large((P_)q);
604 return;
605 }
606
607 /* If the object is in a gen that we're compacting, then we
608 * need to use an alternative evacuate procedure.
609 */
610 if (!is_marked((P_)q,bd)) {
611 mark((P_)q,bd);
612 push_mark_stack((P_)q);
613 }
614 return;
615 }
616
617 gen_no = bd->dest_no;
618
619 info = q->header.info;
620 if (IS_FORWARDING_PTR(info))
621 {
622 /* Already evacuated, just return the forwarding address.
623 * HOWEVER: if the requested destination generation (gct->evac_gen) is
624 * older than the actual generation (because the object was
625 * already evacuated to a younger generation) then we have to
626 * set the gct->failed_to_evac flag to indicate that we couldn't
627 * manage to promote the object to the desired generation.
628 */
629 /*
630 * Optimisation: the check is fairly expensive, but we can often
631 * shortcut it if either the required generation is 0, or the
632 * current object (the EVACUATED) is in a high enough generation.
633 * We know that an EVACUATED always points to an object in the
634 * same or an older generation. gen is the lowest generation that the
635 * current object would be evacuated to, so we only do the full
636 * check if gen is too low.
637 */
638 StgClosure *e = (StgClosure*)UN_FORWARDING_PTR(info);
639 *p = TAG_CLOSURE(tag,e);
640 if (gen_no < gct->evac_gen_no) { // optimisation
641 if (Bdescr((P_)e)->gen_no < gct->evac_gen_no) {
642 gct->failed_to_evac = rtsTrue;
643 TICK_GC_FAILED_PROMOTION();
644 }
645 }
646 return;
647 }
648
649 switch (INFO_PTR_TO_STRUCT(info)->type) {
650
651 case WHITEHOLE:
652 goto loop;
653
654 // For ints and chars of low value, save space by replacing references to
655 // these with closures with references to common, shared ones in the RTS.
656 //
657 // * Except when compiling into Windows DLLs which don't support cross-package
658 // data references very well.
659 //
660 case CONSTR_0_1:
661 {
662 #if defined(COMPILING_WINDOWS_DLL)
663 copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen_no,tag);
664 #else
665 StgWord w = (StgWord)q->payload[0];
666 if (info == Czh_con_info &&
667 // unsigned, so always true: (StgChar)w >= MIN_CHARLIKE &&
668 (StgChar)w <= MAX_CHARLIKE) {
669 *p = TAG_CLOSURE(tag,
670 (StgClosure *)CHARLIKE_CLOSURE((StgChar)w)
671 );
672 }
673 else if (info == Izh_con_info &&
674 (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
675 *p = TAG_CLOSURE(tag,
676 (StgClosure *)INTLIKE_CLOSURE((StgInt)w)
677 );
678 }
679 else {
680 copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen_no,tag);
681 }
682 #endif
683 return;
684 }
685
686 case FUN_0_1:
687 case FUN_1_0:
688 case CONSTR_1_0:
689 copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen_no,tag);
690 return;
691
692 case THUNK_1_0:
693 case THUNK_0_1:
694 copy(p,info,q,sizeofW(StgThunk)+1,gen_no);
695 return;
696
697 case THUNK_1_1:
698 case THUNK_2_0:
699 case THUNK_0_2:
700 #ifdef NO_PROMOTE_THUNKS
701 #error bitrotted
702 #endif
703 copy(p,info,q,sizeofW(StgThunk)+2,gen_no);
704 return;
705
706 case FUN_1_1:
707 case FUN_2_0:
708 case FUN_0_2:
709 case CONSTR_1_1:
710 case CONSTR_2_0:
711 copy_tag_nolock(p,info,q,sizeofW(StgHeader)+2,gen_no,tag);
712 return;
713
714 case CONSTR_0_2:
715 copy_tag_nolock(p,info,q,sizeofW(StgHeader)+2,gen_no,tag);
716 return;
717
718 case THUNK:
719 copy(p,info,q,thunk_sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no);
720 return;
721
722 case FUN:
723 case CONSTR:
724 case CONSTR_NOCAF:
725 copy_tag_nolock(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no,tag);
726 return;
727
728 case BLACKHOLE:
729 {
730 StgClosure *r;
731 const StgInfoTable *i;
732 r = ((StgInd*)q)->indirectee;
733 if (GET_CLOSURE_TAG(r) == 0) {
734 i = r->header.info;
735 if (IS_FORWARDING_PTR(i)) {
736 r = (StgClosure *)UN_FORWARDING_PTR(i);
737 i = r->header.info;
738 }
739 if (i == &stg_TSO_info
740 || i == &stg_WHITEHOLE_info
741 || i == &stg_BLOCKING_QUEUE_CLEAN_info
742 || i == &stg_BLOCKING_QUEUE_DIRTY_info) {
743 copy(p,info,q,sizeofW(StgInd),gen_no);
744 return;
745 }
746 ASSERT(i != &stg_IND_info);
747 }
748 q = r;
749 *p = r;
750 goto loop;
751 }
752
753 case MUT_VAR_CLEAN:
754 case MUT_VAR_DIRTY:
755 case MVAR_CLEAN:
756 case MVAR_DIRTY:
757 case TVAR:
758 case BLOCKING_QUEUE:
759 case WEAK:
760 case PRIM:
761 case MUT_PRIM:
762 copy(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no);
763 return;
764
765 case BCO:
766 copy(p,info,q,bco_sizeW((StgBCO *)q),gen_no);
767 return;
768
769 case THUNK_SELECTOR:
770 eval_thunk_selector(p, (StgSelector *)q, rtsTrue);
771 return;
772
773 case IND:
774 // follow chains of indirections, don't evacuate them
775 q = ((StgInd*)q)->indirectee;
776 *p = q;
777 goto loop;
778
779 case RET_BCO:
780 case RET_SMALL:
781 case RET_BIG:
782 case UPDATE_FRAME:
783 case UNDERFLOW_FRAME:
784 case STOP_FRAME:
785 case CATCH_FRAME:
786 case CATCH_STM_FRAME:
787 case CATCH_RETRY_FRAME:
788 case ATOMICALLY_FRAME:
789 // shouldn't see these
790 barf("evacuate: stack frame at %p\n", q);
791
792 case PAP:
793 copy(p,info,q,pap_sizeW((StgPAP*)q),gen_no);
794 return;
795
796 case AP:
797 copy(p,info,q,ap_sizeW((StgAP*)q),gen_no);
798 return;
799
800 case AP_STACK:
801 copy(p,info,q,ap_stack_sizeW((StgAP_STACK*)q),gen_no);
802 return;
803
804 case ARR_WORDS:
805 // just copy the block
806 copy(p,info,q,arr_words_sizeW((StgArrBytes *)q),gen_no);
807 return;
808
809 case MUT_ARR_PTRS_CLEAN:
810 case MUT_ARR_PTRS_DIRTY:
811 case MUT_ARR_PTRS_FROZEN:
812 case MUT_ARR_PTRS_FROZEN0:
813 // just copy the block
814 copy(p,info,q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),gen_no);
815 return;
816
817 case SMALL_MUT_ARR_PTRS_CLEAN:
818 case SMALL_MUT_ARR_PTRS_DIRTY:
819 case SMALL_MUT_ARR_PTRS_FROZEN:
820 case SMALL_MUT_ARR_PTRS_FROZEN0:
821 // just copy the block
822 copy(p,info,q,small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs *)q),gen_no);
823 return;
824
825 case TSO:
826 copy(p,info,q,sizeofW(StgTSO),gen_no);
827 return;
828
829 case STACK:
830 {
831 StgStack *stack = (StgStack *)q;
832
833 /* To evacuate a small STACK, we need to adjust the stack pointer
834 */
835 {
836 StgStack *new_stack;
837 StgPtr r, s;
838 rtsBool mine;
839
840 mine = copyPart(p,(StgClosure *)stack, stack_sizeW(stack),
841 sizeofW(StgStack), gen_no);
842 if (mine) {
843 new_stack = (StgStack *)*p;
844 move_STACK(stack, new_stack);
845 for (r = stack->sp, s = new_stack->sp;
846 r < stack->stack + stack->stack_size;) {
847 *s++ = *r++;
848 }
849 }
850 return;
851 }
852 }
853
854 case TREC_CHUNK:
855 copy(p,info,q,sizeofW(StgTRecChunk),gen_no);
856 return;
857
858 case COMPACT_NFDATA:
859 // CompactNFData objects are at least one block plus the header
860 // so they are larger than the large_object_threshold (80% of
861 // block size) and never copied by value
862 barf("evacuate: compact nfdata is not large");
863 return;
864 default:
865 barf("evacuate: strange closure type %d", (int)(INFO_PTR_TO_STRUCT(info)->type));
866 }
867
868 barf("evacuate");
869 }
870
871 /* -----------------------------------------------------------------------------
872 Evaluate a THUNK_SELECTOR if possible.
873
874 p points to a THUNK_SELECTOR that we want to evaluate. The
875 result of "evaluating" it will be evacuated and a pointer to the
876 to-space closure will be returned.
877
878 If the THUNK_SELECTOR could not be evaluated (its selectee is still
879 a THUNK, for example), then the THUNK_SELECTOR itself will be
880 evacuated.
881 -------------------------------------------------------------------------- */
882 static void
883 unchain_thunk_selectors(StgSelector *p, StgClosure *val)
884 {
885 StgSelector *prev;
886
887 prev = NULL;
888 while (p)
889 {
890 ASSERT(p->header.info == &stg_WHITEHOLE_info);
891 // val must be in to-space. Not always: when we recursively
892 // invoke eval_thunk_selector(), the recursive calls will not
893 // evacuate the value (because we want to select on the value,
894 // not evacuate it), so in this case val is in from-space.
895 // ASSERT(!HEAP_ALLOCED_GC(val) || Bdescr((P_)val)->gen_no > N || (Bdescr((P_)val)->flags & BF_EVACUATED));
896
897 prev = (StgSelector*)((StgClosure *)p)->payload[0];
898
899 // Update the THUNK_SELECTOR with an indirection to the
900 // value. The value is still in from-space at this stage.
901 //
902 // (old note: Why not do upd_evacuee(q,p)? Because we have an
903 // invariant that an EVACUATED closure always points to an
904 // object in the same or an older generation (required by
905 // the short-cut test in the EVACUATED case, below).
906 if ((StgClosure *)p == val) {
907 // must be a loop; just leave a BLACKHOLE in place. This
908 // can happen when we have a chain of selectors that
909 // eventually loops back on itself. We can't leave an
910 // indirection pointing to itself, and we want the program
911 // to deadlock if it ever enters this closure, so
912 // BLACKHOLE is correct.
913
914 // XXX we do not have BLACKHOLEs any more; replace with
915 // a THUNK_SELECTOR again. This will go into a loop if it is
916 // entered, and should result in a NonTermination exception.
917 ((StgThunk *)p)->payload[0] = val;
918 write_barrier();
919 SET_INFO((StgClosure *)p, &stg_sel_0_upd_info);
920 } else {
921 ((StgInd *)p)->indirectee = val;
922 write_barrier();
923 SET_INFO((StgClosure *)p, &stg_IND_info);
924 }
925
926 // For the purposes of LDV profiling, we have created an
927 // indirection.
928 LDV_RECORD_CREATE(p);
929
930 p = prev;
931 }
932 }
933
934 static void
935 eval_thunk_selector (StgClosure **q, StgSelector * p, rtsBool evac)
936 // NB. for legacy reasons, p & q are swapped around :(
937 {
938 uint32_t field;
939 StgInfoTable *info;
940 StgWord info_ptr;
941 StgClosure *selectee;
942 StgSelector *prev_thunk_selector;
943 bdescr *bd;
944 StgClosure *val;
945
946 prev_thunk_selector = NULL;
947 // this is a chain of THUNK_SELECTORs that we are going to update
948 // to point to the value of the current THUNK_SELECTOR. Each
949 // closure on the chain is a WHITEHOLE, and points to the next in the
950 // chain with payload[0].
951
952 selector_chain:
953
954 bd = Bdescr((StgPtr)p);
955 if (HEAP_ALLOCED_GC(p)) {
956 // If the THUNK_SELECTOR is in to-space or in a generation that we
957 // are not collecting, then bale out early. We won't be able to
958 // save any space in any case, and updating with an indirection is
959 // trickier in a non-collected gen: we would have to update the
960 // mutable list.
961 if (bd->flags & BF_EVACUATED) {
962 unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p);
963 *q = (StgClosure *)p;
964 // shortcut, behave as for: if (evac) evacuate(q);
965 if (evac && bd->gen_no < gct->evac_gen_no) {
966 gct->failed_to_evac = rtsTrue;
967 TICK_GC_FAILED_PROMOTION();
968 }
969 return;
970 }
971 // we don't update THUNK_SELECTORS in the compacted
972 // generation, because compaction does not remove the INDs
973 // that result, this causes confusion later
974 // (scavenge_mark_stack doesn't deal with IND). BEWARE! This
975 // bit is very tricky to get right. If you make changes
976 // around here, test by compiling stage 3 with +RTS -c -RTS.
977 if (bd->flags & BF_MARKED) {
978 // must call evacuate() to mark this closure if evac==rtsTrue
979 *q = (StgClosure *)p;
980 if (evac) evacuate(q);
981 unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p);
982 return;
983 }
984 }
985
986
987 // WHITEHOLE the selector thunk, since it is now under evaluation.
988 // This is important to stop us going into an infinite loop if
989 // this selector thunk eventually refers to itself.
990 #if defined(THREADED_RTS)
991 // In threaded mode, we'll use WHITEHOLE to lock the selector
992 // thunk while we evaluate it.
993 {
994 do {
995 info_ptr = xchg((StgPtr)&p->header.info, (W_)&stg_WHITEHOLE_info);
996 } while (info_ptr == (W_)&stg_WHITEHOLE_info);
997
998 // make sure someone else didn't get here first...
999 if (IS_FORWARDING_PTR(info_ptr) ||
1000 INFO_PTR_TO_STRUCT((StgInfoTable *)info_ptr)->type != THUNK_SELECTOR) {
1001 // v. tricky now. The THUNK_SELECTOR has been evacuated
1002 // by another thread, and is now either a forwarding ptr or IND.
1003 // We need to extract ourselves from the current situation
1004 // as cleanly as possible.
1005 // - unlock the closure
1006 // - update *q, we may have done *some* evaluation
1007 // - if evac, we need to call evacuate(), because we
1008 // need the write-barrier stuff.
1009 // - undo the chain we've built to point to p.
1010 SET_INFO((StgClosure *)p, (const StgInfoTable *)info_ptr);
1011 *q = (StgClosure *)p;
1012 if (evac) evacuate(q);
1013 unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p);
1014 return;
1015 }
1016 }
1017 #else
1018 // Save the real info pointer (NOTE: not the same as get_itbl()).
1019 info_ptr = (StgWord)p->header.info;
1020 SET_INFO((StgClosure *)p,&stg_WHITEHOLE_info);
1021 #endif
1022
1023 field = INFO_PTR_TO_STRUCT((StgInfoTable *)info_ptr)->layout.selector_offset;
1024
1025 // The selectee might be a constructor closure,
1026 // so we untag the pointer.
1027 selectee = UNTAG_CLOSURE(p->selectee);
1028
1029 selector_loop:
1030 // selectee now points to the closure that we're trying to select
1031 // a field from. It may or may not be in to-space: we try not to
1032 // end up in to-space, but it's impractical to avoid it in
1033 // general. The compacting GC scatters to-space pointers in
1034 // from-space during marking, for example. We rely on the property
1035 // that evacuate() doesn't mind if it gets passed a to-space pointer.
1036
1037 info = (StgInfoTable*)selectee->header.info;
1038
1039 if (IS_FORWARDING_PTR(info)) {
1040 // We don't follow pointers into to-space; the constructor
1041 // has already been evacuated, so we won't save any space
1042 // leaks by evaluating this selector thunk anyhow.
1043 goto bale_out;
1044 }
1045
1046 info = INFO_PTR_TO_STRUCT(info);
1047 switch (info->type) {
1048 case WHITEHOLE:
1049 goto bale_out; // about to be evacuated by another thread (or a loop).
1050
1051 case CONSTR:
1052 case CONSTR_1_0:
1053 case CONSTR_0_1:
1054 case CONSTR_2_0:
1055 case CONSTR_1_1:
1056 case CONSTR_0_2:
1057 case CONSTR_NOCAF:
1058 {
1059 // check that the size is in range
1060 ASSERT(field < (StgWord32)(info->layout.payload.ptrs +
1061 info->layout.payload.nptrs));
1062
1063 // Select the right field from the constructor
1064 val = selectee->payload[field];
1065
1066 #ifdef PROFILING
1067 // For the purposes of LDV profiling, we have destroyed
1068 // the original selector thunk, p.
1069 if (era > 0) {
1070 // Only modify the info pointer when LDV profiling is
1071 // enabled. Note that this is incompatible with parallel GC,
1072 // because it would allow other threads to start evaluating
1073 // the same selector thunk.
1074 SET_INFO((StgClosure*)p, (StgInfoTable *)info_ptr);
1075 OVERWRITING_CLOSURE((StgClosure*)p);
1076 SET_INFO((StgClosure*)p, &stg_WHITEHOLE_info);
1077 }
1078 #endif
1079
1080 // the closure in val is now the "value" of the
1081 // THUNK_SELECTOR in p. However, val may itself be a
1082 // THUNK_SELECTOR, in which case we want to continue
1083 // evaluating until we find the real value, and then
1084 // update the whole chain to point to the value.
1085 val_loop:
1086 info_ptr = (StgWord)UNTAG_CLOSURE(val)->header.info;
1087 if (!IS_FORWARDING_PTR(info_ptr))
1088 {
1089 info = INFO_PTR_TO_STRUCT((StgInfoTable *)info_ptr);
1090 switch (info->type) {
1091 case IND:
1092 case IND_STATIC:
1093 val = ((StgInd *)val)->indirectee;
1094 goto val_loop;
1095 case THUNK_SELECTOR:
1096 ((StgClosure*)p)->payload[0] = (StgClosure *)prev_thunk_selector;
1097 prev_thunk_selector = p;
1098 p = (StgSelector*)val;
1099 goto selector_chain;
1100 default:
1101 break;
1102 }
1103 }
1104 ((StgClosure*)p)->payload[0] = (StgClosure *)prev_thunk_selector;
1105 prev_thunk_selector = p;
1106
1107 *q = val;
1108
1109 // update the other selectors in the chain *before*
1110 // evacuating the value. This is necessary in the case
1111 // where the value turns out to be one of the selectors
1112 // in the chain (i.e. we have a loop), and evacuating it
1113 // would corrupt the chain.
1114 unchain_thunk_selectors(prev_thunk_selector, val);
1115
1116 // evacuate() cannot recurse through
1117 // eval_thunk_selector(), because we know val is not
1118 // a THUNK_SELECTOR.
1119 if (evac) evacuate(q);
1120 return;
1121 }
1122
1123 case IND:
1124 case IND_STATIC:
1125 // Again, we might need to untag a constructor.
1126 selectee = UNTAG_CLOSURE( ((StgInd *)selectee)->indirectee );
1127 goto selector_loop;
1128
1129 case BLACKHOLE:
1130 {
1131 StgClosure *r;
1132 const StgInfoTable *i;
1133 r = ((StgInd*)selectee)->indirectee;
1134
1135 // establish whether this BH has been updated, and is now an
1136 // indirection, as in evacuate().
1137 if (GET_CLOSURE_TAG(r) == 0) {
1138 i = r->header.info;
1139 if (IS_FORWARDING_PTR(i)) {
1140 r = (StgClosure *)UN_FORWARDING_PTR(i);
1141 i = r->header.info;
1142 }
1143 if (i == &stg_TSO_info
1144 || i == &stg_WHITEHOLE_info
1145 || i == &stg_BLOCKING_QUEUE_CLEAN_info
1146 || i == &stg_BLOCKING_QUEUE_DIRTY_info) {
1147 goto bale_out;
1148 }
1149 ASSERT(i != &stg_IND_info);
1150 }
1151
1152 selectee = UNTAG_CLOSURE( ((StgInd *)selectee)->indirectee );
1153 goto selector_loop;
1154 }
1155
1156 case THUNK_SELECTOR:
1157 {
1158 StgClosure *val;
1159
1160 // recursively evaluate this selector. We don't want to
1161 // recurse indefinitely, so we impose a depth bound.
1162 if (gct->thunk_selector_depth >= MAX_THUNK_SELECTOR_DEPTH) {
1163 goto bale_out;
1164 }
1165
1166 gct->thunk_selector_depth++;
1167 // rtsFalse says "don't evacuate the result". It will,
1168 // however, update any THUNK_SELECTORs that are evaluated
1169 // along the way.
1170 eval_thunk_selector(&val, (StgSelector*)selectee, rtsFalse);
1171 gct->thunk_selector_depth--;
1172
1173 // did we actually manage to evaluate it?
1174 if (val == selectee) goto bale_out;
1175
1176 // Of course this pointer might be tagged...
1177 selectee = UNTAG_CLOSURE(val);
1178 goto selector_loop;
1179 }
1180
1181 case AP:
1182 case AP_STACK:
1183 case THUNK:
1184 case THUNK_1_0:
1185 case THUNK_0_1:
1186 case THUNK_2_0:
1187 case THUNK_1_1:
1188 case THUNK_0_2:
1189 case THUNK_STATIC:
1190 // not evaluated yet
1191 goto bale_out;
1192
1193 default:
1194 barf("eval_thunk_selector: strange selectee %d",
1195 (int)(info->type));
1196 }
1197
1198 bale_out:
1199 // We didn't manage to evaluate this thunk; restore the old info
1200 // pointer. But don't forget: we still need to evacuate the thunk itself.
1201 SET_INFO((StgClosure *)p, (const StgInfoTable *)info_ptr);
1202 // THREADED_RTS: we just unlocked the thunk, so another thread
1203 // might get in and update it. copy() will lock it again and
1204 // check whether it was updated in the meantime.
1205 *q = (StgClosure *)p;
1206 if (evac) {
1207 copy(q,(const StgInfoTable *)info_ptr,(StgClosure *)p,THUNK_SELECTOR_sizeW(),bd->dest_no);
1208 }
1209 unchain_thunk_selectors(prev_thunk_selector, *q);
1210 return;
1211 }