Use the BF_EVACUATED flag to indicate to-space consistently
[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_COMPACTED)
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 SE_CAF_BLACKHOLE:
625 case SE_BLACKHOLE:
626 case BLACKHOLE:
627 {
628 StgPtr end;
629
630 end = (P_)((StgClosure *)p)->payload +
631 info->layout.payload.ptrs;
632 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
633 thread((StgClosure **)p);
634 }
635 return p + info->layout.payload.nptrs;
636 }
637
638 case WEAK:
639 {
640 StgWeak *w = (StgWeak *)p;
641 thread(&w->key);
642 thread(&w->value);
643 thread(&w->finalizer);
644 if (w->link != NULL) {
645 thread_(&w->link);
646 }
647 return p + sizeofW(StgWeak);
648 }
649
650 case MVAR_CLEAN:
651 case MVAR_DIRTY:
652 {
653 StgMVar *mvar = (StgMVar *)p;
654 thread_(&mvar->head);
655 thread_(&mvar->tail);
656 thread(&mvar->value);
657 return p + sizeofW(StgMVar);
658 }
659
660 case IND_OLDGEN:
661 case IND_OLDGEN_PERM:
662 thread(&((StgInd *)p)->indirectee);
663 return p + sizeofW(StgInd);
664
665 case THUNK_SELECTOR:
666 {
667 StgSelector *s = (StgSelector *)p;
668 thread(&s->selectee);
669 return p + THUNK_SELECTOR_sizeW();
670 }
671
672 case AP_STACK:
673 return thread_AP_STACK((StgAP_STACK *)p);
674
675 case PAP:
676 return thread_PAP((StgPAP *)p);
677
678 case AP:
679 return thread_AP((StgAP *)p);
680
681 case ARR_WORDS:
682 return p + arr_words_sizeW((StgArrWords *)p);
683
684 case MUT_ARR_PTRS_CLEAN:
685 case MUT_ARR_PTRS_DIRTY:
686 case MUT_ARR_PTRS_FROZEN:
687 case MUT_ARR_PTRS_FROZEN0:
688 // follow everything
689 {
690 StgPtr next;
691
692 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
693 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
694 thread((StgClosure **)p);
695 }
696 return p;
697 }
698
699 case TSO:
700 return thread_TSO((StgTSO *)p);
701
702 case TVAR_WATCH_QUEUE:
703 {
704 StgTVarWatchQueue *wq = (StgTVarWatchQueue *)p;
705 thread_(&wq->closure);
706 thread_(&wq->next_queue_entry);
707 thread_(&wq->prev_queue_entry);
708 return p + sizeofW(StgTVarWatchQueue);
709 }
710
711 case TVAR:
712 {
713 StgTVar *tvar = (StgTVar *)p;
714 thread((void *)&tvar->current_value);
715 thread((void *)&tvar->first_watch_queue_entry);
716 return p + sizeofW(StgTVar);
717 }
718
719 case TREC_HEADER:
720 {
721 StgTRecHeader *trec = (StgTRecHeader *)p;
722 thread_(&trec->enclosing_trec);
723 thread_(&trec->current_chunk);
724 thread_(&trec->invariants_to_check);
725 return p + sizeofW(StgTRecHeader);
726 }
727
728 case TREC_CHUNK:
729 {
730 StgWord i;
731 StgTRecChunk *tc = (StgTRecChunk *)p;
732 TRecEntry *e = &(tc -> entries[0]);
733 thread_(&tc->prev_chunk);
734 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
735 thread_(&e->tvar);
736 thread(&e->expected_value);
737 thread(&e->new_value);
738 }
739 return p + sizeofW(StgTRecChunk);
740 }
741
742 case ATOMIC_INVARIANT:
743 {
744 StgAtomicInvariant *invariant = (StgAtomicInvariant *)p;
745 thread_(&invariant->code);
746 thread_(&invariant->last_execution);
747 return p + sizeofW(StgAtomicInvariant);
748 }
749
750 case INVARIANT_CHECK_QUEUE:
751 {
752 StgInvariantCheckQueue *queue = (StgInvariantCheckQueue *)p;
753 thread_(&queue->invariant);
754 thread_(&queue->my_execution);
755 thread_(&queue->next_queue_entry);
756 return p + sizeofW(StgInvariantCheckQueue);
757 }
758
759 default:
760 barf("update_fwd: unknown/strange object %d", (int)(info->type));
761 return NULL;
762 }
763 }
764
765 static void
766 update_fwd( bdescr *blocks )
767 {
768 StgPtr p;
769 bdescr *bd;
770 StgInfoTable *info;
771
772 bd = blocks;
773
774 // cycle through all the blocks in the step
775 for (; bd != NULL; bd = bd->link) {
776 p = bd->start;
777
778 // linearly scan the objects in this block
779 while (p < bd->free) {
780 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
781 info = get_itbl((StgClosure *)p);
782 p = thread_obj(info, p);
783 }
784 }
785 }
786
787 static void
788 update_fwd_compact( bdescr *blocks )
789 {
790 StgPtr p, q, free;
791 #if 0
792 StgWord m;
793 #endif
794 bdescr *bd, *free_bd;
795 StgInfoTable *info;
796 nat size;
797 StgWord iptr;
798
799 bd = blocks;
800 free_bd = blocks;
801 free = free_bd->start;
802
803 // cycle through all the blocks in the step
804 for (; bd != NULL; bd = bd->link) {
805 p = bd->start;
806
807 while (p < bd->free ) {
808
809 while ( p < bd->free && !is_marked(p,bd) ) {
810 p++;
811 }
812 if (p >= bd->free) {
813 break;
814 }
815
816 #if 0
817 next:
818 m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
819 m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
820
821 while ( p < bd->free ) {
822
823 if ((m & 1) == 0) {
824 m >>= 1;
825 p++;
826 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
827 goto next;
828 } else {
829 continue;
830 }
831 }
832 #endif
833
834 // Problem: we need to know the destination for this cell
835 // in order to unthread its info pointer. But we can't
836 // know the destination without the size, because we may
837 // spill into the next block. So we have to run down the
838 // threaded list and get the info ptr first.
839 //
840 // ToDo: one possible avenue of attack is to use the fact
841 // that if (p&BLOCK_MASK) >= (free&BLOCK_MASK), then we
842 // definitely have enough room. Also see bug #1147.
843 iptr = get_threaded_info(p);
844 info = INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)iptr));
845
846 q = p;
847
848 p = thread_obj(info, p);
849
850 size = p - q;
851 if (free + size > free_bd->start + BLOCK_SIZE_W) {
852 // unset the next bit in the bitmap to indicate that
853 // this object needs to be pushed into the next
854 // block. This saves us having to run down the
855 // threaded info pointer list twice during the next pass.
856 unmark(q+1,bd);
857 free_bd = free_bd->link;
858 free = free_bd->start;
859 } else {
860 ASSERT(is_marked(q+1,bd));
861 }
862
863 unthread(q,(StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
864 free += size;
865 #if 0
866 goto next;
867 #endif
868 }
869 }
870 }
871
872 static nat
873 update_bkwd_compact( step *stp )
874 {
875 StgPtr p, free;
876 #if 0
877 StgWord m;
878 #endif
879 bdescr *bd, *free_bd;
880 StgInfoTable *info;
881 nat size, free_blocks;
882 StgWord iptr;
883
884 bd = free_bd = stp->old_blocks;
885 free = free_bd->start;
886 free_blocks = 1;
887
888 // cycle through all the blocks in the step
889 for (; bd != NULL; bd = bd->link) {
890 p = bd->start;
891
892 while (p < bd->free ) {
893
894 while ( p < bd->free && !is_marked(p,bd) ) {
895 p++;
896 }
897 if (p >= bd->free) {
898 break;
899 }
900
901 #if 0
902 next:
903 m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
904 m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
905
906 while ( p < bd->free ) {
907
908 if ((m & 1) == 0) {
909 m >>= 1;
910 p++;
911 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
912 goto next;
913 } else {
914 continue;
915 }
916 }
917 #endif
918
919 if (!is_marked(p+1,bd)) {
920 // don't forget to update the free ptr in the block desc.
921 free_bd->free = free;
922 free_bd = free_bd->link;
923 free = free_bd->start;
924 free_blocks++;
925 }
926
927 iptr = get_threaded_info(p);
928 unthread(p, (StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
929 ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)p)->header.info));
930 info = get_itbl((StgClosure *)p);
931 size = closure_sizeW_((StgClosure *)p,info);
932
933 if (free != p) {
934 move(free,p,size);
935 }
936
937 // relocate TSOs
938 if (info->type == TSO) {
939 move_TSO((StgTSO *)p, (StgTSO *)free);
940 }
941
942 free += size;
943 p += size;
944 #if 0
945 goto next;
946 #endif
947 }
948 }
949
950 // free the remaining blocks and count what's left.
951 free_bd->free = free;
952 if (free_bd->link != NULL) {
953 freeChain(free_bd->link);
954 free_bd->link = NULL;
955 }
956
957 return free_blocks;
958 }
959
960 void
961 compact(StgClosure *static_objects)
962 {
963 nat g, s, blocks;
964 step *stp;
965
966 // 1. thread the roots
967 markCapabilities((evac_fn)thread_root, NULL);
968
969 // the weak pointer lists...
970 if (weak_ptr_list != NULL) {
971 thread((void *)&weak_ptr_list);
972 }
973 if (old_weak_ptr_list != NULL) {
974 thread((void *)&old_weak_ptr_list); // tmp
975 }
976
977 // mutable lists
978 for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
979 bdescr *bd;
980 StgPtr p;
981 for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
982 for (p = bd->start; p < bd->free; p++) {
983 thread((StgClosure **)p);
984 }
985 }
986 }
987
988 // the global thread list
989 thread((void *)&all_threads);
990
991 // any threads resurrected during this GC
992 thread((void *)&resurrected_threads);
993
994 // the task list
995 {
996 Task *task;
997 for (task = all_tasks; task != NULL; task = task->all_link) {
998 if (task->tso) {
999 thread_(&task->tso);
1000 }
1001 }
1002 }
1003
1004 // the static objects
1005 thread_static(static_objects /* ToDo: ok? */);
1006
1007 // the stable pointer table
1008 threadStablePtrTable((evac_fn)thread_root, NULL);
1009
1010 // the CAF list (used by GHCi)
1011 markCAFs((evac_fn)thread_root, NULL);
1012
1013 // 2. update forward ptrs
1014 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1015 for (s = 0; s < generations[g].n_steps; s++) {
1016 if (g==0 && s ==0) continue;
1017 stp = &generations[g].steps[s];
1018 debugTrace(DEBUG_gc, "update_fwd: %d.%d",
1019 stp->gen->no, stp->no);
1020
1021 update_fwd(stp->blocks);
1022 update_fwd_large(stp->scavenged_large_objects);
1023 if (g == RtsFlags.GcFlags.generations-1 && stp->old_blocks != NULL) {
1024 debugTrace(DEBUG_gc, "update_fwd: %d.%d (compact)",
1025 stp->gen->no, stp->no);
1026 update_fwd_compact(stp->old_blocks);
1027 }
1028 }
1029 }
1030
1031 // 3. update backward ptrs
1032 stp = &oldest_gen->steps[0];
1033 if (stp->old_blocks != NULL) {
1034 blocks = update_bkwd_compact(stp);
1035 debugTrace(DEBUG_gc,
1036 "update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)",
1037 stp->gen->no, stp->no,
1038 stp->n_old_blocks, blocks);
1039 stp->n_old_blocks = blocks;
1040 }
1041 }