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