Globally replace "hackage.haskell.org" with "ghc.haskell.org"
[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://ghc.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 == BlockedOnMVarRead
446 || tso->why_blocked == BlockedOnBlackHole
447 || tso->why_blocked == BlockedOnMsgThrowTo
448 || tso->why_blocked == NotBlocked
449 ) {
450 thread_(&tso->block_info.closure);
451 }
452 thread_(&tso->blocked_exceptions);
453 thread_(&tso->bq);
454
455 thread_(&tso->trec);
456
457 thread_(&tso->stackobj);
458 return (StgPtr)tso + sizeofW(StgTSO);
459 }
460
461
462 static void
463 update_fwd_large( bdescr *bd )
464 {
465 StgPtr p;
466 const StgInfoTable* info;
467
468 for (; bd != NULL; bd = bd->link) {
469
470 // nothing to do in a pinned block; it might not even have an object
471 // at the beginning.
472 if (bd->flags & BF_PINNED) continue;
473
474 p = bd->start;
475 info = get_itbl((StgClosure *)p);
476
477 switch (info->type) {
478
479 case ARR_WORDS:
480 // nothing to follow
481 continue;
482
483 case MUT_ARR_PTRS_CLEAN:
484 case MUT_ARR_PTRS_DIRTY:
485 case MUT_ARR_PTRS_FROZEN:
486 case MUT_ARR_PTRS_FROZEN0:
487 // follow everything
488 {
489 StgMutArrPtrs *a;
490
491 a = (StgMutArrPtrs*)p;
492 for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
493 thread((StgClosure **)p);
494 }
495 continue;
496 }
497
498 case STACK:
499 {
500 StgStack *stack = (StgStack*)p;
501 thread_stack(stack->sp, stack->stack + stack->stack_size);
502 continue;
503 }
504
505 case AP_STACK:
506 thread_AP_STACK((StgAP_STACK *)p);
507 continue;
508
509 case PAP:
510 thread_PAP((StgPAP *)p);
511 continue;
512
513 case TREC_CHUNK:
514 {
515 StgWord i;
516 StgTRecChunk *tc = (StgTRecChunk *)p;
517 TRecEntry *e = &(tc -> entries[0]);
518 thread_(&tc->prev_chunk);
519 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
520 thread_(&e->tvar);
521 thread(&e->expected_value);
522 thread(&e->new_value);
523 }
524 continue;
525 }
526
527 default:
528 barf("update_fwd_large: unknown/strange object %d", (int)(info->type));
529 }
530 }
531 }
532
533 // ToDo: too big to inline
534 static /* STATIC_INLINE */ StgPtr
535 thread_obj (StgInfoTable *info, StgPtr p)
536 {
537 switch (info->type) {
538 case THUNK_0_1:
539 return p + sizeofW(StgThunk) + 1;
540
541 case FUN_0_1:
542 case CONSTR_0_1:
543 return p + sizeofW(StgHeader) + 1;
544
545 case FUN_1_0:
546 case CONSTR_1_0:
547 thread(&((StgClosure *)p)->payload[0]);
548 return p + sizeofW(StgHeader) + 1;
549
550 case THUNK_1_0:
551 thread(&((StgThunk *)p)->payload[0]);
552 return p + sizeofW(StgThunk) + 1;
553
554 case THUNK_0_2:
555 return p + sizeofW(StgThunk) + 2;
556
557 case FUN_0_2:
558 case CONSTR_0_2:
559 return p + sizeofW(StgHeader) + 2;
560
561 case THUNK_1_1:
562 thread(&((StgThunk *)p)->payload[0]);
563 return p + sizeofW(StgThunk) + 2;
564
565 case FUN_1_1:
566 case CONSTR_1_1:
567 thread(&((StgClosure *)p)->payload[0]);
568 return p + sizeofW(StgHeader) + 2;
569
570 case THUNK_2_0:
571 thread(&((StgThunk *)p)->payload[0]);
572 thread(&((StgThunk *)p)->payload[1]);
573 return p + sizeofW(StgThunk) + 2;
574
575 case FUN_2_0:
576 case CONSTR_2_0:
577 thread(&((StgClosure *)p)->payload[0]);
578 thread(&((StgClosure *)p)->payload[1]);
579 return p + sizeofW(StgHeader) + 2;
580
581 case BCO: {
582 StgBCO *bco = (StgBCO *)p;
583 thread_(&bco->instrs);
584 thread_(&bco->literals);
585 thread_(&bco->ptrs);
586 return p + bco_sizeW(bco);
587 }
588
589 case THUNK:
590 {
591 StgPtr end;
592
593 end = (P_)((StgThunk *)p)->payload +
594 info->layout.payload.ptrs;
595 for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
596 thread((StgClosure **)p);
597 }
598 return p + info->layout.payload.nptrs;
599 }
600
601 case FUN:
602 case CONSTR:
603 case PRIM:
604 case MUT_PRIM:
605 case MUT_VAR_CLEAN:
606 case MUT_VAR_DIRTY:
607 case TVAR:
608 case BLACKHOLE:
609 case BLOCKING_QUEUE:
610 {
611 StgPtr end;
612
613 end = (P_)((StgClosure *)p)->payload +
614 info->layout.payload.ptrs;
615 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
616 thread((StgClosure **)p);
617 }
618 return p + info->layout.payload.nptrs;
619 }
620
621 case WEAK:
622 {
623 StgWeak *w = (StgWeak *)p;
624 thread(&w->cfinalizers);
625 thread(&w->key);
626 thread(&w->value);
627 thread(&w->finalizer);
628 if (w->link != NULL) {
629 thread_(&w->link);
630 }
631 return p + sizeofW(StgWeak);
632 }
633
634 case MVAR_CLEAN:
635 case MVAR_DIRTY:
636 {
637 StgMVar *mvar = (StgMVar *)p;
638 thread_(&mvar->head);
639 thread_(&mvar->tail);
640 thread(&mvar->value);
641 return p + sizeofW(StgMVar);
642 }
643
644 case IND:
645 case IND_PERM:
646 thread(&((StgInd *)p)->indirectee);
647 return p + sizeofW(StgInd);
648
649 case THUNK_SELECTOR:
650 {
651 StgSelector *s = (StgSelector *)p;
652 thread(&s->selectee);
653 return p + THUNK_SELECTOR_sizeW();
654 }
655
656 case AP_STACK:
657 return thread_AP_STACK((StgAP_STACK *)p);
658
659 case PAP:
660 return thread_PAP((StgPAP *)p);
661
662 case AP:
663 return thread_AP((StgAP *)p);
664
665 case ARR_WORDS:
666 return p + arr_words_sizeW((StgArrWords *)p);
667
668 case MUT_ARR_PTRS_CLEAN:
669 case MUT_ARR_PTRS_DIRTY:
670 case MUT_ARR_PTRS_FROZEN:
671 case MUT_ARR_PTRS_FROZEN0:
672 // follow everything
673 {
674 StgMutArrPtrs *a;
675
676 a = (StgMutArrPtrs *)p;
677 for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
678 thread((StgClosure **)p);
679 }
680
681 return (StgPtr)a + mut_arr_ptrs_sizeW(a);
682 }
683
684 case TSO:
685 return thread_TSO((StgTSO *)p);
686
687 case STACK:
688 {
689 StgStack *stack = (StgStack*)p;
690 thread_stack(stack->sp, stack->stack + stack->stack_size);
691 return p + stack_sizeW(stack);
692 }
693
694 case TREC_CHUNK:
695 {
696 StgWord i;
697 StgTRecChunk *tc = (StgTRecChunk *)p;
698 TRecEntry *e = &(tc -> entries[0]);
699 thread_(&tc->prev_chunk);
700 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
701 thread_(&e->tvar);
702 thread(&e->expected_value);
703 thread(&e->new_value);
704 }
705 return p + sizeofW(StgTRecChunk);
706 }
707
708 default:
709 barf("update_fwd: unknown/strange object %d", (int)(info->type));
710 return NULL;
711 }
712 }
713
714 static void
715 update_fwd( bdescr *blocks )
716 {
717 StgPtr p;
718 bdescr *bd;
719 StgInfoTable *info;
720
721 bd = blocks;
722
723 // cycle through all the blocks in the step
724 for (; bd != NULL; bd = bd->link) {
725 p = bd->start;
726
727 // linearly scan the objects in this block
728 while (p < bd->free) {
729 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
730 info = get_itbl((StgClosure *)p);
731 p = thread_obj(info, p);
732 }
733 }
734 }
735
736 static void
737 update_fwd_compact( bdescr *blocks )
738 {
739 StgPtr p, q, free;
740 #if 0
741 StgWord m;
742 #endif
743 bdescr *bd, *free_bd;
744 StgInfoTable *info;
745 nat size;
746 StgWord iptr;
747
748 bd = blocks;
749 free_bd = blocks;
750 free = free_bd->start;
751
752 // cycle through all the blocks in the step
753 for (; bd != NULL; bd = bd->link) {
754 p = bd->start;
755
756 while (p < bd->free ) {
757
758 while ( p < bd->free && !is_marked(p,bd) ) {
759 p++;
760 }
761 if (p >= bd->free) {
762 break;
763 }
764
765 #if 0
766 next:
767 m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
768 m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
769
770 while ( p < bd->free ) {
771
772 if ((m & 1) == 0) {
773 m >>= 1;
774 p++;
775 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
776 goto next;
777 } else {
778 continue;
779 }
780 }
781 #endif
782
783 // Problem: we need to know the destination for this cell
784 // in order to unthread its info pointer. But we can't
785 // know the destination without the size, because we may
786 // spill into the next block. So we have to run down the
787 // threaded list and get the info ptr first.
788 //
789 // ToDo: one possible avenue of attack is to use the fact
790 // that if (p&BLOCK_MASK) >= (free&BLOCK_MASK), then we
791 // definitely have enough room. Also see bug #1147.
792 iptr = get_threaded_info(p);
793 info = INFO_PTR_TO_STRUCT((StgInfoTable *)UNTAG_CLOSURE((StgClosure *)iptr));
794
795 q = p;
796
797 p = thread_obj(info, p);
798
799 size = p - q;
800 if (free + size > free_bd->start + BLOCK_SIZE_W) {
801 // set the next bit in the bitmap to indicate that
802 // this object needs to be pushed into the next
803 // block. This saves us having to run down the
804 // threaded info pointer list twice during the next pass.
805 mark(q+1,bd);
806 free_bd = free_bd->link;
807 free = free_bd->start;
808 } else {
809 ASSERT(!is_marked(q+1,bd));
810 }
811
812 unthread(q,(StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
813 free += size;
814 #if 0
815 goto next;
816 #endif
817 }
818 }
819 }
820
821 static W_
822 update_bkwd_compact( generation *gen )
823 {
824 StgPtr p, free;
825 #if 0
826 StgWord m;
827 #endif
828 bdescr *bd, *free_bd;
829 StgInfoTable *info;
830 W_ size, free_blocks;
831 StgWord iptr;
832
833 bd = free_bd = gen->old_blocks;
834 free = free_bd->start;
835 free_blocks = 1;
836
837 // cycle through all the blocks in the step
838 for (; bd != NULL; bd = bd->link) {
839 p = bd->start;
840
841 while (p < bd->free ) {
842
843 while ( p < bd->free && !is_marked(p,bd) ) {
844 p++;
845 }
846 if (p >= bd->free) {
847 break;
848 }
849
850 #if 0
851 next:
852 m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
853 m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
854
855 while ( p < bd->free ) {
856
857 if ((m & 1) == 0) {
858 m >>= 1;
859 p++;
860 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
861 goto next;
862 } else {
863 continue;
864 }
865 }
866 #endif
867
868 if (is_marked(p+1,bd)) {
869 // don't forget to update the free ptr in the block desc.
870 free_bd->free = free;
871 free_bd = free_bd->link;
872 free = free_bd->start;
873 free_blocks++;
874 }
875
876 iptr = get_threaded_info(p);
877 unthread(p, (StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
878 ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)((StgClosure *)p)->header.info));
879 info = get_itbl((StgClosure *)p);
880 size = closure_sizeW_((StgClosure *)p,info);
881
882 if (free != p) {
883 move(free,p,size);
884 }
885
886 // relocate TSOs
887 if (info->type == STACK) {
888 move_STACK((StgStack *)p, (StgStack *)free);
889 }
890
891 free += size;
892 p += size;
893 #if 0
894 goto next;
895 #endif
896 }
897 }
898
899 // free the remaining blocks and count what's left.
900 free_bd->free = free;
901 if (free_bd->link != NULL) {
902 freeChain(free_bd->link);
903 free_bd->link = NULL;
904 }
905
906 return free_blocks;
907 }
908
909 void
910 compact(StgClosure *static_objects)
911 {
912 W_ n, g, blocks;
913 generation *gen;
914
915 // 1. thread the roots
916 markCapabilities((evac_fn)thread_root, NULL);
917
918 markScheduler((evac_fn)thread_root, NULL);
919
920 // the weak pointer lists...
921 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
922 if (generations[g].weak_ptr_list != NULL) {
923 thread((void *)&generations[g].weak_ptr_list);
924 }
925 }
926
927 if (dead_weak_ptr_list != NULL) {
928 thread((void *)&dead_weak_ptr_list); // tmp
929 }
930
931 // mutable lists
932 for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
933 bdescr *bd;
934 StgPtr p;
935 for (n = 0; n < n_capabilities; n++) {
936 for (bd = capabilities[n]->mut_lists[g];
937 bd != NULL; bd = bd->link) {
938 for (p = bd->start; p < bd->free; p++) {
939 thread((StgClosure **)p);
940 }
941 }
942 }
943 }
944
945 // the global thread list
946 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
947 thread((void *)&generations[g].threads);
948 }
949
950 // any threads resurrected during this GC
951 thread((void *)&resurrected_threads);
952
953 // the task list
954 {
955 Task *task;
956 InCall *incall;
957 for (task = all_tasks; task != NULL; task = task->all_next) {
958 for (incall = task->incall; incall != NULL;
959 incall = incall->prev_stack) {
960 if (incall->tso) {
961 thread_(&incall->tso);
962 }
963 }
964 }
965 }
966
967 // the static objects
968 thread_static(static_objects /* ToDo: ok? */);
969
970 // the stable pointer table
971 threadStableTables((evac_fn)thread_root, NULL);
972
973 // the CAF list (used by GHCi)
974 markCAFs((evac_fn)thread_root, NULL);
975
976 // 2. update forward ptrs
977 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
978 gen = &generations[g];
979 debugTrace(DEBUG_gc, "update_fwd: %d", g);
980
981 update_fwd(gen->blocks);
982 for (n = 0; n < n_capabilities; n++) {
983 update_fwd(gc_threads[n]->gens[g].todo_bd);
984 update_fwd(gc_threads[n]->gens[g].part_list);
985 }
986 update_fwd_large(gen->scavenged_large_objects);
987 if (g == RtsFlags.GcFlags.generations-1 && gen->old_blocks != NULL) {
988 debugTrace(DEBUG_gc, "update_fwd: %d (compact)", g);
989 update_fwd_compact(gen->old_blocks);
990 }
991 }
992
993 // 3. update backward ptrs
994 gen = oldest_gen;
995 if (gen->old_blocks != NULL) {
996 blocks = update_bkwd_compact(gen);
997 debugTrace(DEBUG_gc,
998 "update_bkwd: %d (compact, old: %d blocks, now %d blocks)",
999 gen->no, gen->n_old_blocks, blocks);
1000 gen->n_old_blocks = blocks;
1001 }
1002 }