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