Fold integer-simple.git into ghc.git (re #8545)
[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 SMALL_MUT_ARR_PTRS_CLEAN:
499 case SMALL_MUT_ARR_PTRS_DIRTY:
500 case SMALL_MUT_ARR_PTRS_FROZEN:
501 case SMALL_MUT_ARR_PTRS_FROZEN0:
502 // follow everything
503 {
504 StgSmallMutArrPtrs *a;
505
506 a = (StgSmallMutArrPtrs*)p;
507 for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
508 thread((StgClosure **)p);
509 }
510 continue;
511 }
512
513 case STACK:
514 {
515 StgStack *stack = (StgStack*)p;
516 thread_stack(stack->sp, stack->stack + stack->stack_size);
517 continue;
518 }
519
520 case AP_STACK:
521 thread_AP_STACK((StgAP_STACK *)p);
522 continue;
523
524 case PAP:
525 thread_PAP((StgPAP *)p);
526 continue;
527
528 case TREC_CHUNK:
529 {
530 StgWord i;
531 StgTRecChunk *tc = (StgTRecChunk *)p;
532 TRecEntry *e = &(tc -> entries[0]);
533 thread_(&tc->prev_chunk);
534 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
535 thread_(&e->tvar);
536 thread(&e->expected_value);
537 thread(&e->new_value);
538 }
539 continue;
540 }
541
542 default:
543 barf("update_fwd_large: unknown/strange object %d", (int)(info->type));
544 }
545 }
546 }
547
548 // ToDo: too big to inline
549 static /* STATIC_INLINE */ StgPtr
550 thread_obj (StgInfoTable *info, StgPtr p)
551 {
552 switch (info->type) {
553 case THUNK_0_1:
554 return p + sizeofW(StgThunk) + 1;
555
556 case FUN_0_1:
557 case CONSTR_0_1:
558 return p + sizeofW(StgHeader) + 1;
559
560 case FUN_1_0:
561 case CONSTR_1_0:
562 thread(&((StgClosure *)p)->payload[0]);
563 return p + sizeofW(StgHeader) + 1;
564
565 case THUNK_1_0:
566 thread(&((StgThunk *)p)->payload[0]);
567 return p + sizeofW(StgThunk) + 1;
568
569 case THUNK_0_2:
570 return p + sizeofW(StgThunk) + 2;
571
572 case FUN_0_2:
573 case CONSTR_0_2:
574 return p + sizeofW(StgHeader) + 2;
575
576 case THUNK_1_1:
577 thread(&((StgThunk *)p)->payload[0]);
578 return p + sizeofW(StgThunk) + 2;
579
580 case FUN_1_1:
581 case CONSTR_1_1:
582 thread(&((StgClosure *)p)->payload[0]);
583 return p + sizeofW(StgHeader) + 2;
584
585 case THUNK_2_0:
586 thread(&((StgThunk *)p)->payload[0]);
587 thread(&((StgThunk *)p)->payload[1]);
588 return p + sizeofW(StgThunk) + 2;
589
590 case FUN_2_0:
591 case CONSTR_2_0:
592 thread(&((StgClosure *)p)->payload[0]);
593 thread(&((StgClosure *)p)->payload[1]);
594 return p + sizeofW(StgHeader) + 2;
595
596 case BCO: {
597 StgBCO *bco = (StgBCO *)p;
598 thread_(&bco->instrs);
599 thread_(&bco->literals);
600 thread_(&bco->ptrs);
601 return p + bco_sizeW(bco);
602 }
603
604 case THUNK:
605 {
606 StgPtr end;
607
608 end = (P_)((StgThunk *)p)->payload +
609 info->layout.payload.ptrs;
610 for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
611 thread((StgClosure **)p);
612 }
613 return p + info->layout.payload.nptrs;
614 }
615
616 case FUN:
617 case CONSTR:
618 case PRIM:
619 case MUT_PRIM:
620 case MUT_VAR_CLEAN:
621 case MUT_VAR_DIRTY:
622 case TVAR:
623 case BLACKHOLE:
624 case BLOCKING_QUEUE:
625 {
626 StgPtr end;
627
628 end = (P_)((StgClosure *)p)->payload +
629 info->layout.payload.ptrs;
630 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
631 thread((StgClosure **)p);
632 }
633 return p + info->layout.payload.nptrs;
634 }
635
636 case WEAK:
637 {
638 StgWeak *w = (StgWeak *)p;
639 thread(&w->cfinalizers);
640 thread(&w->key);
641 thread(&w->value);
642 thread(&w->finalizer);
643 if (w->link != NULL) {
644 thread_(&w->link);
645 }
646 return p + sizeofW(StgWeak);
647 }
648
649 case MVAR_CLEAN:
650 case MVAR_DIRTY:
651 {
652 StgMVar *mvar = (StgMVar *)p;
653 thread_(&mvar->head);
654 thread_(&mvar->tail);
655 thread(&mvar->value);
656 return p + sizeofW(StgMVar);
657 }
658
659 case IND:
660 case IND_PERM:
661 thread(&((StgInd *)p)->indirectee);
662 return p + sizeofW(StgInd);
663
664 case THUNK_SELECTOR:
665 {
666 StgSelector *s = (StgSelector *)p;
667 thread(&s->selectee);
668 return p + THUNK_SELECTOR_sizeW();
669 }
670
671 case AP_STACK:
672 return thread_AP_STACK((StgAP_STACK *)p);
673
674 case PAP:
675 return thread_PAP((StgPAP *)p);
676
677 case AP:
678 return thread_AP((StgAP *)p);
679
680 case ARR_WORDS:
681 return p + arr_words_sizeW((StgArrWords *)p);
682
683 case MUT_ARR_PTRS_CLEAN:
684 case MUT_ARR_PTRS_DIRTY:
685 case MUT_ARR_PTRS_FROZEN:
686 case MUT_ARR_PTRS_FROZEN0:
687 // follow everything
688 {
689 StgMutArrPtrs *a;
690
691 a = (StgMutArrPtrs *)p;
692 for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
693 thread((StgClosure **)p);
694 }
695
696 return (StgPtr)a + mut_arr_ptrs_sizeW(a);
697 }
698
699 case SMALL_MUT_ARR_PTRS_CLEAN:
700 case SMALL_MUT_ARR_PTRS_DIRTY:
701 case SMALL_MUT_ARR_PTRS_FROZEN:
702 case SMALL_MUT_ARR_PTRS_FROZEN0:
703 // follow everything
704 {
705 StgSmallMutArrPtrs *a;
706
707 a = (StgSmallMutArrPtrs *)p;
708 for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
709 thread((StgClosure **)p);
710 }
711
712 return (StgPtr)a + small_mut_arr_ptrs_sizeW(a);
713 }
714
715 case TSO:
716 return thread_TSO((StgTSO *)p);
717
718 case STACK:
719 {
720 StgStack *stack = (StgStack*)p;
721 thread_stack(stack->sp, stack->stack + stack->stack_size);
722 return p + stack_sizeW(stack);
723 }
724
725 case TREC_CHUNK:
726 {
727 StgWord i;
728 StgTRecChunk *tc = (StgTRecChunk *)p;
729 TRecEntry *e = &(tc -> entries[0]);
730 thread_(&tc->prev_chunk);
731 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
732 thread_(&e->tvar);
733 thread(&e->expected_value);
734 thread(&e->new_value);
735 }
736 return p + sizeofW(StgTRecChunk);
737 }
738
739 default:
740 barf("update_fwd: unknown/strange object %d", (int)(info->type));
741 return NULL;
742 }
743 }
744
745 static void
746 update_fwd( bdescr *blocks )
747 {
748 StgPtr p;
749 bdescr *bd;
750 StgInfoTable *info;
751
752 bd = blocks;
753
754 // cycle through all the blocks in the step
755 for (; bd != NULL; bd = bd->link) {
756 p = bd->start;
757
758 // linearly scan the objects in this block
759 while (p < bd->free) {
760 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
761 info = get_itbl((StgClosure *)p);
762 p = thread_obj(info, p);
763 }
764 }
765 }
766
767 static void
768 update_fwd_compact( bdescr *blocks )
769 {
770 StgPtr p, q, free;
771 #if 0
772 StgWord m;
773 #endif
774 bdescr *bd, *free_bd;
775 StgInfoTable *info;
776 nat size;
777 StgWord iptr;
778
779 bd = blocks;
780 free_bd = blocks;
781 free = free_bd->start;
782
783 // cycle through all the blocks in the step
784 for (; bd != NULL; bd = bd->link) {
785 p = bd->start;
786
787 while (p < bd->free ) {
788
789 while ( p < bd->free && !is_marked(p,bd) ) {
790 p++;
791 }
792 if (p >= bd->free) {
793 break;
794 }
795
796 #if 0
797 next:
798 m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
799 m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
800
801 while ( p < bd->free ) {
802
803 if ((m & 1) == 0) {
804 m >>= 1;
805 p++;
806 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
807 goto next;
808 } else {
809 continue;
810 }
811 }
812 #endif
813
814 // Problem: we need to know the destination for this cell
815 // in order to unthread its info pointer. But we can't
816 // know the destination without the size, because we may
817 // spill into the next block. So we have to run down the
818 // threaded list and get the info ptr first.
819 //
820 // ToDo: one possible avenue of attack is to use the fact
821 // that if (p&BLOCK_MASK) >= (free&BLOCK_MASK), then we
822 // definitely have enough room. Also see bug #1147.
823 iptr = get_threaded_info(p);
824 info = INFO_PTR_TO_STRUCT((StgInfoTable *)UNTAG_CLOSURE((StgClosure *)iptr));
825
826 q = p;
827
828 p = thread_obj(info, p);
829
830 size = p - q;
831 if (free + size > free_bd->start + BLOCK_SIZE_W) {
832 // set the next bit in the bitmap to indicate that
833 // this object needs to be pushed into the next
834 // block. This saves us having to run down the
835 // threaded info pointer list twice during the next pass.
836 mark(q+1,bd);
837 free_bd = free_bd->link;
838 free = free_bd->start;
839 } else {
840 ASSERT(!is_marked(q+1,bd));
841 }
842
843 unthread(q,(StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
844 free += size;
845 #if 0
846 goto next;
847 #endif
848 }
849 }
850 }
851
852 static W_
853 update_bkwd_compact( generation *gen )
854 {
855 StgPtr p, free;
856 #if 0
857 StgWord m;
858 #endif
859 bdescr *bd, *free_bd;
860 StgInfoTable *info;
861 W_ size, 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 }