Add optional eager black-holing, with new flag -feager-blackholing
[ghc.git] / rts / sm / Compact.c
1 /* -----------------------------------------------------------------------------
2 *
3 * (c) The GHC Team 2001-2008
4 *
5 * Compacting garbage collector
6 *
7 * Documentation on the architecture of the Garbage Collector can be
8 * found in the online commentary:
9 *
10 * http://hackage.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/GC
11 *
12 * ---------------------------------------------------------------------------*/
13
14 #include "PosixSource.h"
15 #include "Rts.h"
16 #include "RtsUtils.h"
17 #include "RtsFlags.h"
18 #include "OSThreads.h"
19 #include "BlockAlloc.h"
20 #include "MBlock.h"
21 #include "GC.h"
22 #include "Compact.h"
23 #include "Schedule.h"
24 #include "Apply.h"
25 #include "Trace.h"
26
27 // Turn off inlining when debugging - it obfuscates things
28 #ifdef DEBUG
29 # undef STATIC_INLINE
30 # define STATIC_INLINE static
31 #endif
32
33 /* ----------------------------------------------------------------------------
34 Threading / unthreading pointers.
35
36 The basic idea here is to chain together all the fields pointing at
37 a particular object, with the root of the chain in the object's
38 info table field. The original contents of the info pointer goes
39 at the end of the chain.
40
41 Adding a new field to the chain is a matter of swapping the
42 contents of the field with the contents of the object's info table
43 field.
44
45 To unthread the chain, we walk down it updating all the fields on
46 the chain with the new location of the object. We stop when we
47 reach the info pointer at the end.
48
49 The main difficulty here is that we need to be able to identify the
50 info pointer at the end of the chain. We can't use the low bits of
51 the pointer for this; they are already being used for
52 pointer-tagging. What's more, we need to retain the
53 pointer-tagging tag bits on each pointer during the
54 threading/unthreading process.
55
56 Our solution is as follows:
57 - an info pointer (chain length zero) is identified by having tag 0
58 - in a threaded chain of length > 0:
59 - the pointer-tagging tag bits are attached to the info pointer
60 - the first entry in the chain has tag 1
61 - second and subsequent entries in the chain have tag 2
62
63 This exploits the fact that the tag on each pointer to a given
64 closure is normally the same (if they are not the same, then
65 presumably the tag is not essential and it therefore doesn't matter
66 if we throw away some of the tags).
67 ------------------------------------------------------------------------- */
68
69 STATIC_INLINE void
70 thread (StgClosure **p)
71 {
72 StgClosure *q0;
73 StgPtr q;
74 StgWord iptr;
75 bdescr *bd;
76
77 q0 = *p;
78 q = (StgPtr)UNTAG_CLOSURE(q0);
79
80 // It doesn't look like a closure at the moment, because the info
81 // ptr is possibly threaded:
82 // ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
83
84 if (HEAP_ALLOCED(q)) {
85 bd = Bdescr(q);
86
87 if (bd->flags & BF_MARKED)
88 {
89 iptr = *q;
90 switch (GET_CLOSURE_TAG((StgClosure *)iptr))
91 {
92 case 0:
93 // this is the info pointer; we are creating a new chain.
94 // save the original tag at the end of the chain.
95 *p = (StgClosure *)((StgWord)iptr + GET_CLOSURE_TAG(q0));
96 *q = (StgWord)p + 1;
97 break;
98 case 1:
99 case 2:
100 // this is a chain of length 1 or more
101 *p = (StgClosure *)iptr;
102 *q = (StgWord)p + 2;
103 break;
104 }
105 }
106 }
107 }
108
109 static void
110 thread_root (void *user STG_UNUSED, StgClosure **p)
111 {
112 thread(p);
113 }
114
115 // This version of thread() takes a (void *), used to circumvent
116 // warnings from gcc about pointer punning and strict aliasing.
117 STATIC_INLINE void thread_ (void *p) { thread((StgClosure **)p); }
118
119 STATIC_INLINE void
120 unthread( StgPtr p, StgWord free )
121 {
122 StgWord q, r;
123 StgPtr q0;
124
125 q = *p;
126 loop:
127 switch (GET_CLOSURE_TAG((StgClosure *)q))
128 {
129 case 0:
130 // nothing to do; the chain is length zero
131 return;
132 case 1:
133 q0 = (StgPtr)(q-1);
134 r = *q0; // r is the info ptr, tagged with the pointer-tag
135 *q0 = free;
136 *p = (StgWord)UNTAG_CLOSURE((StgClosure *)r);
137 return;
138 case 2:
139 q0 = (StgPtr)(q-2);
140 r = *q0;
141 *q0 = free;
142 q = r;
143 goto loop;
144 default:
145 barf("unthread");
146 }
147 }
148
149 // Traverse a threaded chain and pull out the info pointer at the end.
150 // The info pointer is also tagged with the appropriate pointer tag
151 // for this closure, which should be attached to the pointer
152 // subsequently passed to unthread().
153 STATIC_INLINE StgWord
154 get_threaded_info( StgPtr p )
155 {
156 StgWord q;
157
158 q = (W_)GET_INFO(UNTAG_CLOSURE((StgClosure *)p));
159
160 loop:
161 switch (GET_CLOSURE_TAG((StgClosure *)q))
162 {
163 case 0:
164 ASSERT(LOOKS_LIKE_INFO_PTR(q));
165 return q;
166 case 1:
167 {
168 StgWord r = *(StgPtr)(q-1);
169 ASSERT(LOOKS_LIKE_INFO_PTR(UNTAG_CLOSURE((StgClosure *)r)));
170 return r;
171 }
172 case 2:
173 q = *(StgPtr)(q-2);
174 goto loop;
175 default:
176 barf("get_threaded_info");
177 }
178 }
179
180 // A word-aligned memmove will be faster for small objects than libc's or gcc's.
181 // Remember, the two regions *might* overlap, but: to <= from.
182 STATIC_INLINE void
183 move(StgPtr to, StgPtr from, nat size)
184 {
185 for(; size > 0; --size) {
186 *to++ = *from++;
187 }
188 }
189
190 static void
191 thread_static( StgClosure* p )
192 {
193 const StgInfoTable *info;
194
195 // keep going until we've threaded all the objects on the linked
196 // list...
197 while (p != END_OF_STATIC_LIST) {
198
199 info = get_itbl(p);
200 switch (info->type) {
201
202 case IND_STATIC:
203 thread(&((StgInd *)p)->indirectee);
204 p = *IND_STATIC_LINK(p);
205 continue;
206
207 case THUNK_STATIC:
208 p = *THUNK_STATIC_LINK(p);
209 continue;
210 case FUN_STATIC:
211 p = *FUN_STATIC_LINK(p);
212 continue;
213 case CONSTR_STATIC:
214 p = *STATIC_LINK(info,p);
215 continue;
216
217 default:
218 barf("thread_static: strange closure %d", (int)(info->type));
219 }
220
221 }
222 }
223
224 STATIC_INLINE void
225 thread_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
226 {
227 nat i, b;
228 StgWord bitmap;
229
230 b = 0;
231 bitmap = large_bitmap->bitmap[b];
232 for (i = 0; i < size; ) {
233 if ((bitmap & 1) == 0) {
234 thread((StgClosure **)p);
235 }
236 i++;
237 p++;
238 if (i % BITS_IN(W_) == 0) {
239 b++;
240 bitmap = large_bitmap->bitmap[b];
241 } else {
242 bitmap = bitmap >> 1;
243 }
244 }
245 }
246
247 STATIC_INLINE StgPtr
248 thread_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
249 {
250 StgPtr p;
251 StgWord bitmap;
252 nat size;
253
254 p = (StgPtr)args;
255 switch (fun_info->f.fun_type) {
256 case ARG_GEN:
257 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
258 size = BITMAP_SIZE(fun_info->f.b.bitmap);
259 goto small_bitmap;
260 case ARG_GEN_BIG:
261 size = GET_FUN_LARGE_BITMAP(fun_info)->size;
262 thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
263 p += size;
264 break;
265 default:
266 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
267 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
268 small_bitmap:
269 while (size > 0) {
270 if ((bitmap & 1) == 0) {
271 thread((StgClosure **)p);
272 }
273 p++;
274 bitmap = bitmap >> 1;
275 size--;
276 }
277 break;
278 }
279 return p;
280 }
281
282 static void
283 thread_stack(StgPtr p, StgPtr stack_end)
284 {
285 const StgRetInfoTable* info;
286 StgWord bitmap;
287 nat size;
288
289 // highly similar to scavenge_stack, but we do pointer threading here.
290
291 while (p < stack_end) {
292
293 // *p must be the info pointer of an activation
294 // record. All activation records have 'bitmap' style layout
295 // info.
296 //
297 info = get_ret_itbl((StgClosure *)p);
298
299 switch (info->i.type) {
300
301 // Dynamic bitmap: the mask is stored on the stack
302 case RET_DYN:
303 {
304 StgWord dyn;
305 dyn = ((StgRetDyn *)p)->liveness;
306
307 // traverse the bitmap first
308 bitmap = RET_DYN_LIVENESS(dyn);
309 p = (P_)&((StgRetDyn *)p)->payload[0];
310 size = RET_DYN_BITMAP_SIZE;
311 while (size > 0) {
312 if ((bitmap & 1) == 0) {
313 thread((StgClosure **)p);
314 }
315 p++;
316 bitmap = bitmap >> 1;
317 size--;
318 }
319
320 // skip over the non-ptr words
321 p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
322
323 // follow the ptr words
324 for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
325 thread((StgClosure **)p);
326 p++;
327 }
328 continue;
329 }
330
331 // small bitmap (<= 32 entries, or 64 on a 64-bit machine)
332 case CATCH_RETRY_FRAME:
333 case CATCH_STM_FRAME:
334 case ATOMICALLY_FRAME:
335 case UPDATE_FRAME:
336 case STOP_FRAME:
337 case CATCH_FRAME:
338 case RET_SMALL:
339 bitmap = BITMAP_BITS(info->i.layout.bitmap);
340 size = BITMAP_SIZE(info->i.layout.bitmap);
341 p++;
342 // NOTE: the payload starts immediately after the info-ptr, we
343 // don't have an StgHeader in the same sense as a heap closure.
344 while (size > 0) {
345 if ((bitmap & 1) == 0) {
346 thread((StgClosure **)p);
347 }
348 p++;
349 bitmap = bitmap >> 1;
350 size--;
351 }
352 continue;
353
354 case RET_BCO: {
355 StgBCO *bco;
356 nat size;
357
358 p++;
359 bco = (StgBCO *)*p;
360 thread((StgClosure **)p);
361 p++;
362 size = BCO_BITMAP_SIZE(bco);
363 thread_large_bitmap(p, BCO_BITMAP(bco), size);
364 p += size;
365 continue;
366 }
367
368 // large bitmap (> 32 entries, or 64 on a 64-bit machine)
369 case RET_BIG:
370 p++;
371 size = GET_LARGE_BITMAP(&info->i)->size;
372 thread_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
373 p += size;
374 continue;
375
376 case RET_FUN:
377 {
378 StgRetFun *ret_fun = (StgRetFun *)p;
379 StgFunInfoTable *fun_info;
380
381 fun_info = FUN_INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)
382 get_threaded_info((StgPtr)ret_fun->fun)));
383 // *before* threading it!
384 thread(&ret_fun->fun);
385 p = thread_arg_block(fun_info, ret_fun->payload);
386 continue;
387 }
388
389 default:
390 barf("thread_stack: weird activation record found on stack: %d",
391 (int)(info->i.type));
392 }
393 }
394 }
395
396 STATIC_INLINE StgPtr
397 thread_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
398 {
399 StgPtr p;
400 StgWord bitmap;
401 StgFunInfoTable *fun_info;
402
403 fun_info = FUN_INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)
404 get_threaded_info((StgPtr)fun)));
405 ASSERT(fun_info->i.type != PAP);
406
407 p = (StgPtr)payload;
408
409 switch (fun_info->f.fun_type) {
410 case ARG_GEN:
411 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
412 goto small_bitmap;
413 case ARG_GEN_BIG:
414 thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
415 p += size;
416 break;
417 case ARG_BCO:
418 thread_large_bitmap((StgPtr)payload, BCO_BITMAP(fun), size);
419 p += size;
420 break;
421 default:
422 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
423 small_bitmap:
424 while (size > 0) {
425 if ((bitmap & 1) == 0) {
426 thread((StgClosure **)p);
427 }
428 p++;
429 bitmap = bitmap >> 1;
430 size--;
431 }
432 break;
433 }
434
435 return p;
436 }
437
438 STATIC_INLINE StgPtr
439 thread_PAP (StgPAP *pap)
440 {
441 StgPtr p;
442 p = thread_PAP_payload(pap->fun, pap->payload, pap->n_args);
443 thread(&pap->fun);
444 return p;
445 }
446
447 STATIC_INLINE StgPtr
448 thread_AP (StgAP *ap)
449 {
450 StgPtr p;
451 p = thread_PAP_payload(ap->fun, ap->payload, ap->n_args);
452 thread(&ap->fun);
453 return p;
454 }
455
456 STATIC_INLINE StgPtr
457 thread_AP_STACK (StgAP_STACK *ap)
458 {
459 thread(&ap->fun);
460 thread_stack((P_)ap->payload, (P_)ap->payload + ap->size);
461 return (P_)ap + sizeofW(StgAP_STACK) + ap->size;
462 }
463
464 static StgPtr
465 thread_TSO (StgTSO *tso)
466 {
467 thread_(&tso->_link);
468 thread_(&tso->global_link);
469
470 if ( tso->why_blocked == BlockedOnMVar
471 || tso->why_blocked == BlockedOnBlackHole
472 || tso->why_blocked == BlockedOnException
473 ) {
474 thread_(&tso->block_info.closure);
475 }
476 thread_(&tso->blocked_exceptions);
477
478 thread_(&tso->trec);
479
480 thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
481 return (StgPtr)tso + tso_sizeW(tso);
482 }
483
484
485 static void
486 update_fwd_large( bdescr *bd )
487 {
488 StgPtr p;
489 const StgInfoTable* info;
490
491 for (; bd != NULL; bd = bd->link) {
492
493 p = bd->start;
494 info = get_itbl((StgClosure *)p);
495
496 switch (info->type) {
497
498 case ARR_WORDS:
499 // nothing to follow
500 continue;
501
502 case MUT_ARR_PTRS_CLEAN:
503 case MUT_ARR_PTRS_DIRTY:
504 case MUT_ARR_PTRS_FROZEN:
505 case MUT_ARR_PTRS_FROZEN0:
506 // follow everything
507 {
508 StgPtr next;
509
510 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
511 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
512 thread((StgClosure **)p);
513 }
514 continue;
515 }
516
517 case TSO:
518 thread_TSO((StgTSO *)p);
519 continue;
520
521 case AP_STACK:
522 thread_AP_STACK((StgAP_STACK *)p);
523 continue;
524
525 case PAP:
526 thread_PAP((StgPAP *)p);
527 continue;
528
529 case TREC_CHUNK:
530 {
531 StgWord i;
532 StgTRecChunk *tc = (StgTRecChunk *)p;
533 TRecEntry *e = &(tc -> entries[0]);
534 thread_(&tc->prev_chunk);
535 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
536 thread_(&e->tvar);
537 thread(&e->expected_value);
538 thread(&e->new_value);
539 }
540 continue;
541 }
542
543 default:
544 barf("update_fwd_large: unknown/strange object %d", (int)(info->type));
545 }
546 }
547 }
548
549 // ToDo: too big to inline
550 static /* STATIC_INLINE */ StgPtr
551 thread_obj (StgInfoTable *info, StgPtr p)
552 {
553 switch (info->type) {
554 case THUNK_0_1:
555 return p + sizeofW(StgThunk) + 1;
556
557 case FUN_0_1:
558 case CONSTR_0_1:
559 return p + sizeofW(StgHeader) + 1;
560
561 case FUN_1_0:
562 case CONSTR_1_0:
563 thread(&((StgClosure *)p)->payload[0]);
564 return p + sizeofW(StgHeader) + 1;
565
566 case THUNK_1_0:
567 thread(&((StgThunk *)p)->payload[0]);
568 return p + sizeofW(StgThunk) + 1;
569
570 case THUNK_0_2:
571 return p + sizeofW(StgThunk) + 2;
572
573 case FUN_0_2:
574 case CONSTR_0_2:
575 return p + sizeofW(StgHeader) + 2;
576
577 case THUNK_1_1:
578 thread(&((StgThunk *)p)->payload[0]);
579 return p + sizeofW(StgThunk) + 2;
580
581 case FUN_1_1:
582 case CONSTR_1_1:
583 thread(&((StgClosure *)p)->payload[0]);
584 return p + sizeofW(StgHeader) + 2;
585
586 case THUNK_2_0:
587 thread(&((StgThunk *)p)->payload[0]);
588 thread(&((StgThunk *)p)->payload[1]);
589 return p + sizeofW(StgThunk) + 2;
590
591 case FUN_2_0:
592 case CONSTR_2_0:
593 thread(&((StgClosure *)p)->payload[0]);
594 thread(&((StgClosure *)p)->payload[1]);
595 return p + sizeofW(StgHeader) + 2;
596
597 case BCO: {
598 StgBCO *bco = (StgBCO *)p;
599 thread_(&bco->instrs);
600 thread_(&bco->literals);
601 thread_(&bco->ptrs);
602 return p + bco_sizeW(bco);
603 }
604
605 case THUNK:
606 {
607 StgPtr end;
608
609 end = (P_)((StgThunk *)p)->payload +
610 info->layout.payload.ptrs;
611 for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
612 thread((StgClosure **)p);
613 }
614 return p + info->layout.payload.nptrs;
615 }
616
617 case FUN:
618 case CONSTR:
619 case STABLE_NAME:
620 case IND_PERM:
621 case MUT_VAR_CLEAN:
622 case MUT_VAR_DIRTY:
623 case CAF_BLACKHOLE:
624 case BLACKHOLE:
625 {
626 StgPtr end;
627
628 end = (P_)((StgClosure *)p)->payload +
629 info->layout.payload.ptrs;
630 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
631 thread((StgClosure **)p);
632 }
633 return p + info->layout.payload.nptrs;
634 }
635
636 case WEAK:
637 {
638 StgWeak *w = (StgWeak *)p;
639 thread(&w->key);
640 thread(&w->value);
641 thread(&w->finalizer);
642 if (w->link != NULL) {
643 thread_(&w->link);
644 }
645 return p + sizeofW(StgWeak);
646 }
647
648 case MVAR_CLEAN:
649 case MVAR_DIRTY:
650 {
651 StgMVar *mvar = (StgMVar *)p;
652 thread_(&mvar->head);
653 thread_(&mvar->tail);
654 thread(&mvar->value);
655 return p + sizeofW(StgMVar);
656 }
657
658 case IND_OLDGEN:
659 case IND_OLDGEN_PERM:
660 thread(&((StgInd *)p)->indirectee);
661 return p + sizeofW(StgInd);
662
663 case THUNK_SELECTOR:
664 {
665 StgSelector *s = (StgSelector *)p;
666 thread(&s->selectee);
667 return p + THUNK_SELECTOR_sizeW();
668 }
669
670 case AP_STACK:
671 return thread_AP_STACK((StgAP_STACK *)p);
672
673 case PAP:
674 return thread_PAP((StgPAP *)p);
675
676 case AP:
677 return thread_AP((StgAP *)p);
678
679 case ARR_WORDS:
680 return p + arr_words_sizeW((StgArrWords *)p);
681
682 case MUT_ARR_PTRS_CLEAN:
683 case MUT_ARR_PTRS_DIRTY:
684 case MUT_ARR_PTRS_FROZEN:
685 case MUT_ARR_PTRS_FROZEN0:
686 // follow everything
687 {
688 StgPtr next;
689
690 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
691 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
692 thread((StgClosure **)p);
693 }
694 return p;
695 }
696
697 case TSO:
698 return thread_TSO((StgTSO *)p);
699
700 case TVAR_WATCH_QUEUE:
701 {
702 StgTVarWatchQueue *wq = (StgTVarWatchQueue *)p;
703 thread_(&wq->closure);
704 thread_(&wq->next_queue_entry);
705 thread_(&wq->prev_queue_entry);
706 return p + sizeofW(StgTVarWatchQueue);
707 }
708
709 case TVAR:
710 {
711 StgTVar *tvar = (StgTVar *)p;
712 thread((void *)&tvar->current_value);
713 thread((void *)&tvar->first_watch_queue_entry);
714 return p + sizeofW(StgTVar);
715 }
716
717 case TREC_HEADER:
718 {
719 StgTRecHeader *trec = (StgTRecHeader *)p;
720 thread_(&trec->enclosing_trec);
721 thread_(&trec->current_chunk);
722 thread_(&trec->invariants_to_check);
723 return p + sizeofW(StgTRecHeader);
724 }
725
726 case TREC_CHUNK:
727 {
728 StgWord i;
729 StgTRecChunk *tc = (StgTRecChunk *)p;
730 TRecEntry *e = &(tc -> entries[0]);
731 thread_(&tc->prev_chunk);
732 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
733 thread_(&e->tvar);
734 thread(&e->expected_value);
735 thread(&e->new_value);
736 }
737 return p + sizeofW(StgTRecChunk);
738 }
739
740 case ATOMIC_INVARIANT:
741 {
742 StgAtomicInvariant *invariant = (StgAtomicInvariant *)p;
743 thread_(&invariant->code);
744 thread_(&invariant->last_execution);
745 return p + sizeofW(StgAtomicInvariant);
746 }
747
748 case INVARIANT_CHECK_QUEUE:
749 {
750 StgInvariantCheckQueue *queue = (StgInvariantCheckQueue *)p;
751 thread_(&queue->invariant);
752 thread_(&queue->my_execution);
753 thread_(&queue->next_queue_entry);
754 return p + sizeofW(StgInvariantCheckQueue);
755 }
756
757 default:
758 barf("update_fwd: unknown/strange object %d", (int)(info->type));
759 return NULL;
760 }
761 }
762
763 static void
764 update_fwd( bdescr *blocks )
765 {
766 StgPtr p;
767 bdescr *bd;
768 StgInfoTable *info;
769
770 bd = blocks;
771
772 // cycle through all the blocks in the step
773 for (; bd != NULL; bd = bd->link) {
774 p = bd->start;
775
776 // linearly scan the objects in this block
777 while (p < bd->free) {
778 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
779 info = get_itbl((StgClosure *)p);
780 p = thread_obj(info, p);
781 }
782 }
783 }
784
785 static void
786 update_fwd_compact( bdescr *blocks )
787 {
788 StgPtr p, q, free;
789 #if 0
790 StgWord m;
791 #endif
792 bdescr *bd, *free_bd;
793 StgInfoTable *info;
794 nat size;
795 StgWord iptr;
796
797 bd = blocks;
798 free_bd = blocks;
799 free = free_bd->start;
800
801 // cycle through all the blocks in the step
802 for (; bd != NULL; bd = bd->link) {
803 p = bd->start;
804
805 while (p < bd->free ) {
806
807 while ( p < bd->free && !is_marked(p,bd) ) {
808 p++;
809 }
810 if (p >= bd->free) {
811 break;
812 }
813
814 #if 0
815 next:
816 m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
817 m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
818
819 while ( p < bd->free ) {
820
821 if ((m & 1) == 0) {
822 m >>= 1;
823 p++;
824 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
825 goto next;
826 } else {
827 continue;
828 }
829 }
830 #endif
831
832 // Problem: we need to know the destination for this cell
833 // in order to unthread its info pointer. But we can't
834 // know the destination without the size, because we may
835 // spill into the next block. So we have to run down the
836 // threaded list and get the info ptr first.
837 //
838 // ToDo: one possible avenue of attack is to use the fact
839 // that if (p&BLOCK_MASK) >= (free&BLOCK_MASK), then we
840 // definitely have enough room. Also see bug #1147.
841 iptr = get_threaded_info(p);
842 info = INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)iptr));
843
844 q = p;
845
846 p = thread_obj(info, p);
847
848 size = p - q;
849 if (free + size > free_bd->start + BLOCK_SIZE_W) {
850 // unset the next bit in the bitmap to indicate that
851 // this object needs to be pushed into the next
852 // block. This saves us having to run down the
853 // threaded info pointer list twice during the next pass.
854 unmark(q+1,bd);
855 free_bd = free_bd->link;
856 free = free_bd->start;
857 } else {
858 ASSERT(is_marked(q+1,bd));
859 }
860
861 unthread(q,(StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
862 free += size;
863 #if 0
864 goto next;
865 #endif
866 }
867 }
868 }
869
870 static nat
871 update_bkwd_compact( step *stp )
872 {
873 StgPtr p, free;
874 #if 0
875 StgWord m;
876 #endif
877 bdescr *bd, *free_bd;
878 StgInfoTable *info;
879 nat size, free_blocks;
880 StgWord iptr;
881
882 bd = free_bd = stp->old_blocks;
883 free = free_bd->start;
884 free_blocks = 1;
885
886 // cycle through all the blocks in the step
887 for (; bd != NULL; bd = bd->link) {
888 p = bd->start;
889
890 while (p < bd->free ) {
891
892 while ( p < bd->free && !is_marked(p,bd) ) {
893 p++;
894 }
895 if (p >= bd->free) {
896 break;
897 }
898
899 #if 0
900 next:
901 m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
902 m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
903
904 while ( p < bd->free ) {
905
906 if ((m & 1) == 0) {
907 m >>= 1;
908 p++;
909 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
910 goto next;
911 } else {
912 continue;
913 }
914 }
915 #endif
916
917 if (!is_marked(p+1,bd)) {
918 // don't forget to update the free ptr in the block desc.
919 free_bd->free = free;
920 free_bd = free_bd->link;
921 free = free_bd->start;
922 free_blocks++;
923 }
924
925 iptr = get_threaded_info(p);
926 unthread(p, (StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
927 ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)p)->header.info));
928 info = get_itbl((StgClosure *)p);
929 size = closure_sizeW_((StgClosure *)p,info);
930
931 if (free != p) {
932 move(free,p,size);
933 }
934
935 // relocate TSOs
936 if (info->type == TSO) {
937 move_TSO((StgTSO *)p, (StgTSO *)free);
938 }
939
940 free += size;
941 p += size;
942 #if 0
943 goto next;
944 #endif
945 }
946 }
947
948 // free the remaining blocks and count what's left.
949 free_bd->free = free;
950 if (free_bd->link != NULL) {
951 freeChain(free_bd->link);
952 free_bd->link = NULL;
953 }
954
955 return free_blocks;
956 }
957
958 void
959 compact(StgClosure *static_objects)
960 {
961 nat g, s, blocks;
962 step *stp;
963
964 // 1. thread the roots
965 markCapabilities((evac_fn)thread_root, NULL);
966
967 // the weak pointer lists...
968 if (weak_ptr_list != NULL) {
969 thread((void *)&weak_ptr_list);
970 }
971 if (old_weak_ptr_list != NULL) {
972 thread((void *)&old_weak_ptr_list); // tmp
973 }
974
975 // mutable lists
976 for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
977 bdescr *bd;
978 StgPtr p;
979 for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
980 for (p = bd->start; p < bd->free; p++) {
981 thread((StgClosure **)p);
982 }
983 }
984 }
985
986 // the global thread list
987 for (s = 0; s < total_steps; s++) {
988 thread((void *)&all_steps[s].threads);
989 }
990
991 // any threads resurrected during this GC
992 thread((void *)&resurrected_threads);
993
994 // the blackhole queue
995 thread((void *)&blackhole_queue);
996
997 // the task list
998 {
999 Task *task;
1000 for (task = all_tasks; task != NULL; task = task->all_link) {
1001 if (task->tso) {
1002 thread_(&task->tso);
1003 }
1004 }
1005 }
1006
1007 // the static objects
1008 thread_static(static_objects /* ToDo: ok? */);
1009
1010 // the stable pointer table
1011 threadStablePtrTable((evac_fn)thread_root, NULL);
1012
1013 // the CAF list (used by GHCi)
1014 markCAFs((evac_fn)thread_root, NULL);
1015
1016 // 2. update forward ptrs
1017 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1018 for (s = 0; s < generations[g].n_steps; s++) {
1019 if (g==0 && s ==0) continue;
1020 stp = &generations[g].steps[s];
1021 debugTrace(DEBUG_gc, "update_fwd: %d.%d",
1022 stp->gen->no, stp->no);
1023
1024 update_fwd(stp->blocks);
1025 update_fwd_large(stp->scavenged_large_objects);
1026 if (g == RtsFlags.GcFlags.generations-1 && stp->old_blocks != NULL) {
1027 debugTrace(DEBUG_gc, "update_fwd: %d.%d (compact)",
1028 stp->gen->no, stp->no);
1029 update_fwd_compact(stp->old_blocks);
1030 }
1031 }
1032 }
1033
1034 // 3. update backward ptrs
1035 stp = &oldest_gen->steps[0];
1036 if (stp->old_blocks != NULL) {
1037 blocks = update_bkwd_compact(stp);
1038 debugTrace(DEBUG_gc,
1039 "update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)",
1040 stp->gen->no, stp->no,
1041 stp->n_old_blocks, blocks);
1042 stp->n_old_blocks = blocks;
1043 }
1044 }