Rts: Consistently use StgWord for sizes of bitmaps
[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, StgWord 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, StgWord 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 StgWord 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 StgWord 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
331 p++;
332 bco = (StgBCO *)*p;
333 thread((StgClosure **)p);
334 p++;
335 size = BCO_BITMAP_SIZE(bco);
336 thread_large_bitmap(p, BCO_BITMAP(bco), size);
337 p += size;
338 continue;
339 }
340
341 // large bitmap (> 32 entries, or 64 on a 64-bit machine)
342 case RET_BIG:
343 p++;
344 size = GET_LARGE_BITMAP(&info->i)->size;
345 thread_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
346 p += size;
347 continue;
348
349 case RET_FUN:
350 {
351 StgRetFun *ret_fun = (StgRetFun *)p;
352 StgFunInfoTable *fun_info;
353
354 fun_info = FUN_INFO_PTR_TO_STRUCT((StgInfoTable *)UNTAG_CLOSURE((StgClosure *)
355 get_threaded_info((StgPtr)ret_fun->fun)));
356 // *before* threading it!
357 thread(&ret_fun->fun);
358 p = thread_arg_block(fun_info, ret_fun->payload);
359 continue;
360 }
361
362 default:
363 barf("thread_stack: weird activation record found on stack: %d",
364 (int)(info->i.type));
365 }
366 }
367 }
368
369 STATIC_INLINE StgPtr
370 thread_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
371 {
372 StgPtr p;
373 StgWord bitmap;
374 StgFunInfoTable *fun_info;
375
376 fun_info = FUN_INFO_PTR_TO_STRUCT((StgInfoTable *)UNTAG_CLOSURE((StgClosure *)
377 get_threaded_info((StgPtr)fun)));
378 ASSERT(fun_info->i.type != PAP);
379
380 p = (StgPtr)payload;
381
382 switch (fun_info->f.fun_type) {
383 case ARG_GEN:
384 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
385 goto small_bitmap;
386 case ARG_GEN_BIG:
387 thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
388 p += size;
389 break;
390 case ARG_BCO:
391 thread_large_bitmap((StgPtr)payload, BCO_BITMAP(fun), size);
392 p += size;
393 break;
394 default:
395 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
396 small_bitmap:
397 while (size > 0) {
398 if ((bitmap & 1) == 0) {
399 thread((StgClosure **)p);
400 }
401 p++;
402 bitmap = bitmap >> 1;
403 size--;
404 }
405 break;
406 }
407
408 return p;
409 }
410
411 STATIC_INLINE StgPtr
412 thread_PAP (StgPAP *pap)
413 {
414 StgPtr p;
415 p = thread_PAP_payload(pap->fun, pap->payload, pap->n_args);
416 thread(&pap->fun);
417 return p;
418 }
419
420 STATIC_INLINE StgPtr
421 thread_AP (StgAP *ap)
422 {
423 StgPtr p;
424 p = thread_PAP_payload(ap->fun, ap->payload, ap->n_args);
425 thread(&ap->fun);
426 return p;
427 }
428
429 STATIC_INLINE StgPtr
430 thread_AP_STACK (StgAP_STACK *ap)
431 {
432 thread(&ap->fun);
433 thread_stack((P_)ap->payload, (P_)ap->payload + ap->size);
434 return (P_)ap + sizeofW(StgAP_STACK) + ap->size;
435 }
436
437 static StgPtr
438 thread_TSO (StgTSO *tso)
439 {
440 thread_(&tso->_link);
441 thread_(&tso->global_link);
442
443 if ( tso->why_blocked == BlockedOnMVar
444 || tso->why_blocked == BlockedOnMVarRead
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 SMALL_MUT_ARR_PTRS_CLEAN:
498 case SMALL_MUT_ARR_PTRS_DIRTY:
499 case SMALL_MUT_ARR_PTRS_FROZEN:
500 case SMALL_MUT_ARR_PTRS_FROZEN0:
501 // follow everything
502 {
503 StgSmallMutArrPtrs *a;
504
505 a = (StgSmallMutArrPtrs*)p;
506 for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
507 thread((StgClosure **)p);
508 }
509 continue;
510 }
511
512 case STACK:
513 {
514 StgStack *stack = (StgStack*)p;
515 thread_stack(stack->sp, stack->stack + stack->stack_size);
516 continue;
517 }
518
519 case AP_STACK:
520 thread_AP_STACK((StgAP_STACK *)p);
521 continue;
522
523 case PAP:
524 thread_PAP((StgPAP *)p);
525 continue;
526
527 case TREC_CHUNK:
528 {
529 StgWord i;
530 StgTRecChunk *tc = (StgTRecChunk *)p;
531 TRecEntry *e = &(tc -> entries[0]);
532 thread_(&tc->prev_chunk);
533 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
534 thread_(&e->tvar);
535 thread(&e->expected_value);
536 thread(&e->new_value);
537 }
538 continue;
539 }
540
541 default:
542 barf("update_fwd_large: unknown/strange object %d", (int)(info->type));
543 }
544 }
545 }
546
547 // ToDo: too big to inline
548 static /* STATIC_INLINE */ StgPtr
549 thread_obj (StgInfoTable *info, StgPtr p)
550 {
551 switch (info->type) {
552 case THUNK_0_1:
553 return p + sizeofW(StgThunk) + 1;
554
555 case FUN_0_1:
556 case CONSTR_0_1:
557 return p + sizeofW(StgHeader) + 1;
558
559 case FUN_1_0:
560 case CONSTR_1_0:
561 thread(&((StgClosure *)p)->payload[0]);
562 return p + sizeofW(StgHeader) + 1;
563
564 case THUNK_1_0:
565 thread(&((StgThunk *)p)->payload[0]);
566 return p + sizeofW(StgThunk) + 1;
567
568 case THUNK_0_2:
569 return p + sizeofW(StgThunk) + 2;
570
571 case FUN_0_2:
572 case CONSTR_0_2:
573 return p + sizeofW(StgHeader) + 2;
574
575 case THUNK_1_1:
576 thread(&((StgThunk *)p)->payload[0]);
577 return p + sizeofW(StgThunk) + 2;
578
579 case FUN_1_1:
580 case CONSTR_1_1:
581 thread(&((StgClosure *)p)->payload[0]);
582 return p + sizeofW(StgHeader) + 2;
583
584 case THUNK_2_0:
585 thread(&((StgThunk *)p)->payload[0]);
586 thread(&((StgThunk *)p)->payload[1]);
587 return p + sizeofW(StgThunk) + 2;
588
589 case FUN_2_0:
590 case CONSTR_2_0:
591 thread(&((StgClosure *)p)->payload[0]);
592 thread(&((StgClosure *)p)->payload[1]);
593 return p + sizeofW(StgHeader) + 2;
594
595 case BCO: {
596 StgBCO *bco = (StgBCO *)p;
597 thread_(&bco->instrs);
598 thread_(&bco->literals);
599 thread_(&bco->ptrs);
600 return p + bco_sizeW(bco);
601 }
602
603 case THUNK:
604 {
605 StgPtr end;
606
607 end = (P_)((StgThunk *)p)->payload +
608 info->layout.payload.ptrs;
609 for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
610 thread((StgClosure **)p);
611 }
612 return p + info->layout.payload.nptrs;
613 }
614
615 case FUN:
616 case CONSTR:
617 case PRIM:
618 case MUT_PRIM:
619 case MUT_VAR_CLEAN:
620 case MUT_VAR_DIRTY:
621 case TVAR:
622 case BLACKHOLE:
623 case BLOCKING_QUEUE:
624 {
625 StgPtr end;
626
627 end = (P_)((StgClosure *)p)->payload +
628 info->layout.payload.ptrs;
629 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
630 thread((StgClosure **)p);
631 }
632 return p + info->layout.payload.nptrs;
633 }
634
635 case WEAK:
636 {
637 StgWeak *w = (StgWeak *)p;
638 thread(&w->cfinalizers);
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:
659 case IND_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 StgMutArrPtrs *a;
689
690 a = (StgMutArrPtrs *)p;
691 for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
692 thread((StgClosure **)p);
693 }
694
695 return (StgPtr)a + mut_arr_ptrs_sizeW(a);
696 }
697
698 case SMALL_MUT_ARR_PTRS_CLEAN:
699 case SMALL_MUT_ARR_PTRS_DIRTY:
700 case SMALL_MUT_ARR_PTRS_FROZEN:
701 case SMALL_MUT_ARR_PTRS_FROZEN0:
702 // follow everything
703 {
704 StgSmallMutArrPtrs *a;
705
706 a = (StgSmallMutArrPtrs *)p;
707 for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
708 thread((StgClosure **)p);
709 }
710
711 return (StgPtr)a + small_mut_arr_ptrs_sizeW(a);
712 }
713
714 case TSO:
715 return thread_TSO((StgTSO *)p);
716
717 case STACK:
718 {
719 StgStack *stack = (StgStack*)p;
720 thread_stack(stack->sp, stack->stack + stack->stack_size);
721 return p + stack_sizeW(stack);
722 }
723
724 case TREC_CHUNK:
725 {
726 StgWord i;
727 StgTRecChunk *tc = (StgTRecChunk *)p;
728 TRecEntry *e = &(tc -> entries[0]);
729 thread_(&tc->prev_chunk);
730 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
731 thread_(&e->tvar);
732 thread(&e->expected_value);
733 thread(&e->new_value);
734 }
735 return p + sizeofW(StgTRecChunk);
736 }
737
738 default:
739 barf("update_fwd: unknown/strange object %d", (int)(info->type));
740 return NULL;
741 }
742 }
743
744 static void
745 update_fwd( bdescr *blocks )
746 {
747 StgPtr p;
748 bdescr *bd;
749 StgInfoTable *info;
750
751 bd = blocks;
752
753 // cycle through all the blocks in the step
754 for (; bd != NULL; bd = bd->link) {
755 p = bd->start;
756
757 // linearly scan the objects in this block
758 while (p < bd->free) {
759 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
760 info = get_itbl((StgClosure *)p);
761 p = thread_obj(info, p);
762 }
763 }
764 }
765
766 static void
767 update_fwd_compact( bdescr *blocks )
768 {
769 StgPtr p, q, free;
770 #if 0
771 StgWord m;
772 #endif
773 bdescr *bd, *free_bd;
774 StgInfoTable *info;
775 StgWord size;
776 StgWord iptr;
777
778 bd = blocks;
779 free_bd = blocks;
780 free = free_bd->start;
781
782 // cycle through all the blocks in the step
783 for (; bd != NULL; bd = bd->link) {
784 p = bd->start;
785
786 while (p < bd->free ) {
787
788 while ( p < bd->free && !is_marked(p,bd) ) {
789 p++;
790 }
791 if (p >= bd->free) {
792 break;
793 }
794
795 #if 0
796 next:
797 m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
798 m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
799
800 while ( p < bd->free ) {
801
802 if ((m & 1) == 0) {
803 m >>= 1;
804 p++;
805 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
806 goto next;
807 } else {
808 continue;
809 }
810 }
811 #endif
812
813 // Problem: we need to know the destination for this cell
814 // in order to unthread its info pointer. But we can't
815 // know the destination without the size, because we may
816 // spill into the next block. So we have to run down the
817 // threaded list and get the info ptr first.
818 //
819 // ToDo: one possible avenue of attack is to use the fact
820 // that if (p&BLOCK_MASK) >= (free&BLOCK_MASK), then we
821 // definitely have enough room. Also see bug #1147.
822 iptr = get_threaded_info(p);
823 info = INFO_PTR_TO_STRUCT((StgInfoTable *)UNTAG_CLOSURE((StgClosure *)iptr));
824
825 q = p;
826
827 p = thread_obj(info, p);
828
829 size = p - q;
830 if (free + size > free_bd->start + BLOCK_SIZE_W) {
831 // set the next bit in the bitmap to indicate that
832 // this object needs to be pushed into the next
833 // block. This saves us having to run down the
834 // threaded info pointer list twice during the next pass.
835 mark(q+1,bd);
836 free_bd = free_bd->link;
837 free = free_bd->start;
838 } else {
839 ASSERT(!is_marked(q+1,bd));
840 }
841
842 unthread(q,(StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
843 free += size;
844 #if 0
845 goto next;
846 #endif
847 }
848 }
849 }
850
851 static W_
852 update_bkwd_compact( generation *gen )
853 {
854 StgPtr p, free;
855 #if 0
856 StgWord m;
857 #endif
858 bdescr *bd, *free_bd;
859 StgInfoTable *info;
860 StgWord size;
861 W_ free_blocks;
862 StgWord iptr;
863
864 bd = free_bd = gen->old_blocks;
865 free = free_bd->start;
866 free_blocks = 1;
867
868 // cycle through all the blocks in the step
869 for (; bd != NULL; bd = bd->link) {
870 p = bd->start;
871
872 while (p < bd->free ) {
873
874 while ( p < bd->free && !is_marked(p,bd) ) {
875 p++;
876 }
877 if (p >= bd->free) {
878 break;
879 }
880
881 #if 0
882 next:
883 m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
884 m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
885
886 while ( p < bd->free ) {
887
888 if ((m & 1) == 0) {
889 m >>= 1;
890 p++;
891 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
892 goto next;
893 } else {
894 continue;
895 }
896 }
897 #endif
898
899 if (is_marked(p+1,bd)) {
900 // don't forget to update the free ptr in the block desc.
901 free_bd->free = free;
902 free_bd = free_bd->link;
903 free = free_bd->start;
904 free_blocks++;
905 }
906
907 iptr = get_threaded_info(p);
908 unthread(p, (StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
909 ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)((StgClosure *)p)->header.info));
910 info = get_itbl((StgClosure *)p);
911 size = closure_sizeW_((StgClosure *)p,info);
912
913 if (free != p) {
914 move(free,p,size);
915 }
916
917 // relocate TSOs
918 if (info->type == STACK) {
919 move_STACK((StgStack *)p, (StgStack *)free);
920 }
921
922 free += size;
923 p += size;
924 #if 0
925 goto next;
926 #endif
927 }
928 }
929
930 // free the remaining blocks and count what's left.
931 free_bd->free = free;
932 if (free_bd->link != NULL) {
933 freeChain(free_bd->link);
934 free_bd->link = NULL;
935 }
936
937 return free_blocks;
938 }
939
940 void
941 compact(StgClosure *static_objects)
942 {
943 W_ n, g, blocks;
944 generation *gen;
945
946 // 1. thread the roots
947 markCapabilities((evac_fn)thread_root, NULL);
948
949 markScheduler((evac_fn)thread_root, NULL);
950
951 // the weak pointer lists...
952 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
953 if (generations[g].weak_ptr_list != NULL) {
954 thread((void *)&generations[g].weak_ptr_list);
955 }
956 }
957
958 if (dead_weak_ptr_list != NULL) {
959 thread((void *)&dead_weak_ptr_list); // tmp
960 }
961
962 // mutable lists
963 for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
964 bdescr *bd;
965 StgPtr p;
966 for (n = 0; n < n_capabilities; n++) {
967 for (bd = capabilities[n]->mut_lists[g];
968 bd != NULL; bd = bd->link) {
969 for (p = bd->start; p < bd->free; p++) {
970 thread((StgClosure **)p);
971 }
972 }
973 }
974 }
975
976 // the global thread list
977 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
978 thread((void *)&generations[g].threads);
979 }
980
981 // any threads resurrected during this GC
982 thread((void *)&resurrected_threads);
983
984 // the task list
985 {
986 Task *task;
987 InCall *incall;
988 for (task = all_tasks; task != NULL; task = task->all_next) {
989 for (incall = task->incall; incall != NULL;
990 incall = incall->prev_stack) {
991 if (incall->tso) {
992 thread_(&incall->tso);
993 }
994 }
995 }
996 }
997
998 // the static objects
999 thread_static(static_objects /* ToDo: ok? */);
1000
1001 // the stable pointer table
1002 threadStableTables((evac_fn)thread_root, NULL);
1003
1004 // the CAF list (used by GHCi)
1005 markCAFs((evac_fn)thread_root, NULL);
1006
1007 // 2. update forward ptrs
1008 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1009 gen = &generations[g];
1010 debugTrace(DEBUG_gc, "update_fwd: %d", g);
1011
1012 update_fwd(gen->blocks);
1013 for (n = 0; n < n_capabilities; n++) {
1014 update_fwd(gc_threads[n]->gens[g].todo_bd);
1015 update_fwd(gc_threads[n]->gens[g].part_list);
1016 }
1017 update_fwd_large(gen->scavenged_large_objects);
1018 if (g == RtsFlags.GcFlags.generations-1 && gen->old_blocks != NULL) {
1019 debugTrace(DEBUG_gc, "update_fwd: %d (compact)", g);
1020 update_fwd_compact(gen->old_blocks);
1021 }
1022 }
1023
1024 // 3. update backward ptrs
1025 gen = oldest_gen;
1026 if (gen->old_blocks != NULL) {
1027 blocks = update_bkwd_compact(gen);
1028 debugTrace(DEBUG_gc,
1029 "update_bkwd: %d (compact, old: %d blocks, now %d blocks)",
1030 gen->no, gen->n_old_blocks, blocks);
1031 gen->n_old_blocks = blocks;
1032 }
1033 }