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