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