Fix bug in the handling of TSOs in the compacting GC (#5644)
[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, nat 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, nat size )
229 {
230 nat 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 nat 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 nat 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 // Dynamic bitmap: the mask is stored on the stack
305 case RET_DYN:
306 {
307 StgWord dyn;
308 dyn = ((StgRetDyn *)p)->liveness;
309
310 // traverse the bitmap first
311 bitmap = RET_DYN_LIVENESS(dyn);
312 p = (P_)&((StgRetDyn *)p)->payload[0];
313 size = RET_DYN_BITMAP_SIZE;
314 while (size > 0) {
315 if ((bitmap & 1) == 0) {
316 thread((StgClosure **)p);
317 }
318 p++;
319 bitmap = bitmap >> 1;
320 size--;
321 }
322
323 // skip over the non-ptr words
324 p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
325
326 // follow the ptr words
327 for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
328 thread((StgClosure **)p);
329 p++;
330 }
331 continue;
332 }
333
334 // small bitmap (<= 32 entries, or 64 on a 64-bit machine)
335 case CATCH_RETRY_FRAME:
336 case CATCH_STM_FRAME:
337 case ATOMICALLY_FRAME:
338 case UPDATE_FRAME:
339 case UNDERFLOW_FRAME:
340 case STOP_FRAME:
341 case CATCH_FRAME:
342 case RET_SMALL:
343 bitmap = BITMAP_BITS(info->i.layout.bitmap);
344 size = BITMAP_SIZE(info->i.layout.bitmap);
345 p++;
346 // NOTE: the payload starts immediately after the info-ptr, we
347 // don't have an StgHeader in the same sense as a heap closure.
348 while (size > 0) {
349 if ((bitmap & 1) == 0) {
350 thread((StgClosure **)p);
351 }
352 p++;
353 bitmap = bitmap >> 1;
354 size--;
355 }
356 continue;
357
358 case RET_BCO: {
359 StgBCO *bco;
360 nat size;
361
362 p++;
363 bco = (StgBCO *)*p;
364 thread((StgClosure **)p);
365 p++;
366 size = BCO_BITMAP_SIZE(bco);
367 thread_large_bitmap(p, BCO_BITMAP(bco), size);
368 p += size;
369 continue;
370 }
371
372 // large bitmap (> 32 entries, or 64 on a 64-bit machine)
373 case RET_BIG:
374 p++;
375 size = GET_LARGE_BITMAP(&info->i)->size;
376 thread_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
377 p += size;
378 continue;
379
380 case RET_FUN:
381 {
382 StgRetFun *ret_fun = (StgRetFun *)p;
383 StgFunInfoTable *fun_info;
384
385 fun_info = FUN_INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)
386 get_threaded_info((StgPtr)ret_fun->fun)));
387 // *before* threading it!
388 thread(&ret_fun->fun);
389 p = thread_arg_block(fun_info, ret_fun->payload);
390 continue;
391 }
392
393 default:
394 barf("thread_stack: weird activation record found on stack: %d",
395 (int)(info->i.type));
396 }
397 }
398 }
399
400 STATIC_INLINE StgPtr
401 thread_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
402 {
403 StgPtr p;
404 StgWord bitmap;
405 StgFunInfoTable *fun_info;
406
407 fun_info = FUN_INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)
408 get_threaded_info((StgPtr)fun)));
409 ASSERT(fun_info->i.type != PAP);
410
411 p = (StgPtr)payload;
412
413 switch (fun_info->f.fun_type) {
414 case ARG_GEN:
415 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
416 goto small_bitmap;
417 case ARG_GEN_BIG:
418 thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
419 p += size;
420 break;
421 case ARG_BCO:
422 thread_large_bitmap((StgPtr)payload, BCO_BITMAP(fun), size);
423 p += size;
424 break;
425 default:
426 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
427 small_bitmap:
428 while (size > 0) {
429 if ((bitmap & 1) == 0) {
430 thread((StgClosure **)p);
431 }
432 p++;
433 bitmap = bitmap >> 1;
434 size--;
435 }
436 break;
437 }
438
439 return p;
440 }
441
442 STATIC_INLINE StgPtr
443 thread_PAP (StgPAP *pap)
444 {
445 StgPtr p;
446 p = thread_PAP_payload(pap->fun, pap->payload, pap->n_args);
447 thread(&pap->fun);
448 return p;
449 }
450
451 STATIC_INLINE StgPtr
452 thread_AP (StgAP *ap)
453 {
454 StgPtr p;
455 p = thread_PAP_payload(ap->fun, ap->payload, ap->n_args);
456 thread(&ap->fun);
457 return p;
458 }
459
460 STATIC_INLINE StgPtr
461 thread_AP_STACK (StgAP_STACK *ap)
462 {
463 thread(&ap->fun);
464 thread_stack((P_)ap->payload, (P_)ap->payload + ap->size);
465 return (P_)ap + sizeofW(StgAP_STACK) + ap->size;
466 }
467
468 static StgPtr
469 thread_TSO (StgTSO *tso)
470 {
471 thread_(&tso->_link);
472 thread_(&tso->global_link);
473
474 if ( tso->why_blocked == BlockedOnMVar
475 || tso->why_blocked == BlockedOnBlackHole
476 || tso->why_blocked == BlockedOnMsgThrowTo
477 || tso->why_blocked == NotBlocked
478 ) {
479 thread_(&tso->block_info.closure);
480 }
481 thread_(&tso->blocked_exceptions);
482 thread_(&tso->bq);
483
484 thread_(&tso->trec);
485
486 thread_(&tso->stackobj);
487 return (StgPtr)tso + sizeofW(StgTSO);
488 }
489
490
491 static void
492 update_fwd_large( bdescr *bd )
493 {
494 StgPtr p;
495 const StgInfoTable* info;
496
497 for (; bd != NULL; bd = bd->link) {
498
499 // nothing to do in a pinned block; it might not even have an object
500 // at the beginning.
501 if (bd->flags & BF_PINNED) continue;
502
503 p = bd->start;
504 info = get_itbl((StgClosure *)p);
505
506 switch (info->type) {
507
508 case ARR_WORDS:
509 // nothing to follow
510 continue;
511
512 case MUT_ARR_PTRS_CLEAN:
513 case MUT_ARR_PTRS_DIRTY:
514 case MUT_ARR_PTRS_FROZEN:
515 case MUT_ARR_PTRS_FROZEN0:
516 // follow everything
517 {
518 StgMutArrPtrs *a;
519
520 a = (StgMutArrPtrs*)p;
521 for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
522 thread((StgClosure **)p);
523 }
524 continue;
525 }
526
527 case STACK:
528 {
529 StgStack *stack = (StgStack*)p;
530 thread_stack(stack->sp, stack->stack + stack->stack_size);
531 continue;
532 }
533
534 case AP_STACK:
535 thread_AP_STACK((StgAP_STACK *)p);
536 continue;
537
538 case PAP:
539 thread_PAP((StgPAP *)p);
540 continue;
541
542 case TREC_CHUNK:
543 {
544 StgWord i;
545 StgTRecChunk *tc = (StgTRecChunk *)p;
546 TRecEntry *e = &(tc -> entries[0]);
547 thread_(&tc->prev_chunk);
548 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
549 thread_(&e->tvar);
550 thread(&e->expected_value);
551 thread(&e->new_value);
552 }
553 continue;
554 }
555
556 default:
557 barf("update_fwd_large: unknown/strange object %d", (int)(info->type));
558 }
559 }
560 }
561
562 // ToDo: too big to inline
563 static /* STATIC_INLINE */ StgPtr
564 thread_obj (StgInfoTable *info, StgPtr p)
565 {
566 switch (info->type) {
567 case THUNK_0_1:
568 return p + sizeofW(StgThunk) + 1;
569
570 case FUN_0_1:
571 case CONSTR_0_1:
572 return p + sizeofW(StgHeader) + 1;
573
574 case FUN_1_0:
575 case CONSTR_1_0:
576 thread(&((StgClosure *)p)->payload[0]);
577 return p + sizeofW(StgHeader) + 1;
578
579 case THUNK_1_0:
580 thread(&((StgThunk *)p)->payload[0]);
581 return p + sizeofW(StgThunk) + 1;
582
583 case THUNK_0_2:
584 return p + sizeofW(StgThunk) + 2;
585
586 case FUN_0_2:
587 case CONSTR_0_2:
588 return p + sizeofW(StgHeader) + 2;
589
590 case THUNK_1_1:
591 thread(&((StgThunk *)p)->payload[0]);
592 return p + sizeofW(StgThunk) + 2;
593
594 case FUN_1_1:
595 case CONSTR_1_1:
596 thread(&((StgClosure *)p)->payload[0]);
597 return p + sizeofW(StgHeader) + 2;
598
599 case THUNK_2_0:
600 thread(&((StgThunk *)p)->payload[0]);
601 thread(&((StgThunk *)p)->payload[1]);
602 return p + sizeofW(StgThunk) + 2;
603
604 case FUN_2_0:
605 case CONSTR_2_0:
606 thread(&((StgClosure *)p)->payload[0]);
607 thread(&((StgClosure *)p)->payload[1]);
608 return p + sizeofW(StgHeader) + 2;
609
610 case BCO: {
611 StgBCO *bco = (StgBCO *)p;
612 thread_(&bco->instrs);
613 thread_(&bco->literals);
614 thread_(&bco->ptrs);
615 return p + bco_sizeW(bco);
616 }
617
618 case THUNK:
619 {
620 StgPtr end;
621
622 end = (P_)((StgThunk *)p)->payload +
623 info->layout.payload.ptrs;
624 for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
625 thread((StgClosure **)p);
626 }
627 return p + info->layout.payload.nptrs;
628 }
629
630 case FUN:
631 case CONSTR:
632 case PRIM:
633 case MUT_PRIM:
634 case MUT_VAR_CLEAN:
635 case MUT_VAR_DIRTY:
636 case BLACKHOLE:
637 case BLOCKING_QUEUE:
638 {
639 StgPtr end;
640
641 end = (P_)((StgClosure *)p)->payload +
642 info->layout.payload.ptrs;
643 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
644 thread((StgClosure **)p);
645 }
646 return p + info->layout.payload.nptrs;
647 }
648
649 case WEAK:
650 {
651 StgWeak *w = (StgWeak *)p;
652 thread(&w->cfinalizer);
653 thread(&w->key);
654 thread(&w->value);
655 thread(&w->finalizer);
656 if (w->link != NULL) {
657 thread_(&w->link);
658 }
659 return p + sizeofW(StgWeak);
660 }
661
662 case MVAR_CLEAN:
663 case MVAR_DIRTY:
664 {
665 StgMVar *mvar = (StgMVar *)p;
666 thread_(&mvar->head);
667 thread_(&mvar->tail);
668 thread(&mvar->value);
669 return p + sizeofW(StgMVar);
670 }
671
672 case IND:
673 case IND_PERM:
674 thread(&((StgInd *)p)->indirectee);
675 return p + sizeofW(StgInd);
676
677 case THUNK_SELECTOR:
678 {
679 StgSelector *s = (StgSelector *)p;
680 thread(&s->selectee);
681 return p + THUNK_SELECTOR_sizeW();
682 }
683
684 case AP_STACK:
685 return thread_AP_STACK((StgAP_STACK *)p);
686
687 case PAP:
688 return thread_PAP((StgPAP *)p);
689
690 case AP:
691 return thread_AP((StgAP *)p);
692
693 case ARR_WORDS:
694 return p + arr_words_sizeW((StgArrWords *)p);
695
696 case MUT_ARR_PTRS_CLEAN:
697 case MUT_ARR_PTRS_DIRTY:
698 case MUT_ARR_PTRS_FROZEN:
699 case MUT_ARR_PTRS_FROZEN0:
700 // follow everything
701 {
702 StgMutArrPtrs *a;
703
704 a = (StgMutArrPtrs *)p;
705 for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
706 thread((StgClosure **)p);
707 }
708
709 return (StgPtr)a + mut_arr_ptrs_sizeW(a);
710 }
711
712 case TSO:
713 return thread_TSO((StgTSO *)p);
714
715 case STACK:
716 {
717 StgStack *stack = (StgStack*)p;
718 thread_stack(stack->sp, stack->stack + stack->stack_size);
719 return p + stack_sizeW(stack);
720 }
721
722 case TREC_CHUNK:
723 {
724 StgWord i;
725 StgTRecChunk *tc = (StgTRecChunk *)p;
726 TRecEntry *e = &(tc -> entries[0]);
727 thread_(&tc->prev_chunk);
728 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
729 thread_(&e->tvar);
730 thread(&e->expected_value);
731 thread(&e->new_value);
732 }
733 return p + sizeofW(StgTRecChunk);
734 }
735
736 default:
737 barf("update_fwd: unknown/strange object %d", (int)(info->type));
738 return NULL;
739 }
740 }
741
742 static void
743 update_fwd( bdescr *blocks )
744 {
745 StgPtr p;
746 bdescr *bd;
747 StgInfoTable *info;
748
749 bd = blocks;
750
751 // cycle through all the blocks in the step
752 for (; bd != NULL; bd = bd->link) {
753 p = bd->start;
754
755 // linearly scan the objects in this block
756 while (p < bd->free) {
757 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
758 info = get_itbl((StgClosure *)p);
759 p = thread_obj(info, p);
760 }
761 }
762 }
763
764 static void
765 update_fwd_compact( bdescr *blocks )
766 {
767 StgPtr p, q, free;
768 #if 0
769 StgWord m;
770 #endif
771 bdescr *bd, *free_bd;
772 StgInfoTable *info;
773 nat size;
774 StgWord iptr;
775
776 bd = blocks;
777 free_bd = blocks;
778 free = free_bd->start;
779
780 // cycle through all the blocks in the step
781 for (; bd != NULL; bd = bd->link) {
782 p = bd->start;
783
784 while (p < bd->free ) {
785
786 while ( p < bd->free && !is_marked(p,bd) ) {
787 p++;
788 }
789 if (p >= bd->free) {
790 break;
791 }
792
793 #if 0
794 next:
795 m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
796 m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
797
798 while ( p < bd->free ) {
799
800 if ((m & 1) == 0) {
801 m >>= 1;
802 p++;
803 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
804 goto next;
805 } else {
806 continue;
807 }
808 }
809 #endif
810
811 // Problem: we need to know the destination for this cell
812 // in order to unthread its info pointer. But we can't
813 // know the destination without the size, because we may
814 // spill into the next block. So we have to run down the
815 // threaded list and get the info ptr first.
816 //
817 // ToDo: one possible avenue of attack is to use the fact
818 // that if (p&BLOCK_MASK) >= (free&BLOCK_MASK), then we
819 // definitely have enough room. Also see bug #1147.
820 iptr = get_threaded_info(p);
821 info = INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)iptr));
822
823 q = p;
824
825 p = thread_obj(info, p);
826
827 size = p - q;
828 if (free + size > free_bd->start + BLOCK_SIZE_W) {
829 // set the next bit in the bitmap to indicate that
830 // this object needs to be pushed into the next
831 // block. This saves us having to run down the
832 // threaded info pointer list twice during the next pass.
833 mark(q+1,bd);
834 free_bd = free_bd->link;
835 free = free_bd->start;
836 } else {
837 ASSERT(!is_marked(q+1,bd));
838 }
839
840 unthread(q,(StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
841 free += size;
842 #if 0
843 goto next;
844 #endif
845 }
846 }
847 }
848
849 static nat
850 update_bkwd_compact( generation *gen )
851 {
852 StgPtr p, free;
853 #if 0
854 StgWord m;
855 #endif
856 bdescr *bd, *free_bd;
857 StgInfoTable *info;
858 nat size, free_blocks;
859 StgWord iptr;
860
861 bd = free_bd = gen->old_blocks;
862 free = free_bd->start;
863 free_blocks = 1;
864
865 // cycle through all the blocks in the step
866 for (; bd != NULL; bd = bd->link) {
867 p = bd->start;
868
869 while (p < bd->free ) {
870
871 while ( p < bd->free && !is_marked(p,bd) ) {
872 p++;
873 }
874 if (p >= bd->free) {
875 break;
876 }
877
878 #if 0
879 next:
880 m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
881 m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
882
883 while ( p < bd->free ) {
884
885 if ((m & 1) == 0) {
886 m >>= 1;
887 p++;
888 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
889 goto next;
890 } else {
891 continue;
892 }
893 }
894 #endif
895
896 if (is_marked(p+1,bd)) {
897 // don't forget to update the free ptr in the block desc.
898 free_bd->free = free;
899 free_bd = free_bd->link;
900 free = free_bd->start;
901 free_blocks++;
902 }
903
904 iptr = get_threaded_info(p);
905 unthread(p, (StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
906 ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)((StgClosure *)p)->header.info));
907 info = get_itbl((StgClosure *)p);
908 size = closure_sizeW_((StgClosure *)p,info);
909
910 if (free != p) {
911 move(free,p,size);
912 }
913
914 // relocate TSOs
915 if (info->type == STACK) {
916 move_STACK((StgStack *)p, (StgStack *)free);
917 }
918
919 free += size;
920 p += size;
921 #if 0
922 goto next;
923 #endif
924 }
925 }
926
927 // free the remaining blocks and count what's left.
928 free_bd->free = free;
929 if (free_bd->link != NULL) {
930 freeChain(free_bd->link);
931 free_bd->link = NULL;
932 }
933
934 return free_blocks;
935 }
936
937 void
938 compact(StgClosure *static_objects)
939 {
940 nat n, g, blocks;
941 generation *gen;
942
943 // 1. thread the roots
944 markCapabilities((evac_fn)thread_root, NULL);
945
946 markScheduler((evac_fn)thread_root, NULL);
947
948 // the weak pointer lists...
949 if (weak_ptr_list != NULL) {
950 thread((void *)&weak_ptr_list);
951 }
952 if (old_weak_ptr_list != NULL) {
953 thread((void *)&old_weak_ptr_list); // tmp
954 }
955
956 // mutable lists
957 for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
958 bdescr *bd;
959 StgPtr p;
960 for (n = 0; n < n_capabilities; n++) {
961 for (bd = capabilities[n].mut_lists[g];
962 bd != NULL; bd = bd->link) {
963 for (p = bd->start; p < bd->free; p++) {
964 thread((StgClosure **)p);
965 }
966 }
967 }
968 }
969
970 // the global thread list
971 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
972 thread((void *)&generations[g].threads);
973 }
974
975 // any threads resurrected during this GC
976 thread((void *)&resurrected_threads);
977
978 // the task list
979 {
980 Task *task;
981 InCall *incall;
982 for (task = all_tasks; task != NULL; task = task->all_link) {
983 for (incall = task->incall; incall != NULL;
984 incall = incall->prev_stack) {
985 if (incall->tso) {
986 thread_(&incall->tso);
987 }
988 }
989 }
990 }
991
992 // the static objects
993 thread_static(static_objects /* ToDo: ok? */);
994
995 // the stable pointer table
996 threadStablePtrTable((evac_fn)thread_root, NULL);
997
998 // the CAF list (used by GHCi)
999 markCAFs((evac_fn)thread_root, NULL);
1000
1001 // 2. update forward ptrs
1002 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1003 gen = &generations[g];
1004 debugTrace(DEBUG_gc, "update_fwd: %d", g);
1005
1006 update_fwd(gen->blocks);
1007 for (n = 0; n < n_capabilities; n++) {
1008 update_fwd(gc_threads[n]->gens[g].todo_bd);
1009 update_fwd(gc_threads[n]->gens[g].part_list);
1010 }
1011 update_fwd_large(gen->scavenged_large_objects);
1012 if (g == RtsFlags.GcFlags.generations-1 && gen->old_blocks != NULL) {
1013 debugTrace(DEBUG_gc, "update_fwd: %d (compact)", g);
1014 update_fwd_compact(gen->old_blocks);
1015 }
1016 }
1017
1018 // 3. update backward ptrs
1019 gen = oldest_gen;
1020 if (gen->old_blocks != NULL) {
1021 blocks = update_bkwd_compact(gen);
1022 debugTrace(DEBUG_gc,
1023 "update_bkwd: %d (compact, old: %d blocks, now %d blocks)",
1024 gen->no, gen->n_old_blocks, blocks);
1025 gen->n_old_blocks = blocks;
1026 }
1027 }