RTS tidyup sweep, first phase
[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 == BlockedOnException
475 ) {
476 thread_(&tso->block_info.closure);
477 }
478 thread_(&tso->blocked_exceptions);
479
480 thread_(&tso->trec);
481
482 thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
483 return (StgPtr)tso + tso_sizeW(tso);
484 }
485
486
487 static void
488 update_fwd_large( bdescr *bd )
489 {
490 StgPtr p;
491 const StgInfoTable* info;
492
493 for (; bd != NULL; bd = bd->link) {
494
495 // nothing to do in a pinned block; it might not even have an object
496 // at the beginning.
497 if (bd->flags & BF_PINNED) continue;
498
499 p = bd->start;
500 info = get_itbl((StgClosure *)p);
501
502 switch (info->type) {
503
504 case ARR_WORDS:
505 // nothing to follow
506 continue;
507
508 case MUT_ARR_PTRS_CLEAN:
509 case MUT_ARR_PTRS_DIRTY:
510 case MUT_ARR_PTRS_FROZEN:
511 case MUT_ARR_PTRS_FROZEN0:
512 // follow everything
513 {
514 StgPtr next;
515
516 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
517 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
518 thread((StgClosure **)p);
519 }
520 continue;
521 }
522
523 case TSO:
524 thread_TSO((StgTSO *)p);
525 continue;
526
527 case AP_STACK:
528 thread_AP_STACK((StgAP_STACK *)p);
529 continue;
530
531 case PAP:
532 thread_PAP((StgPAP *)p);
533 continue;
534
535 case TREC_CHUNK:
536 {
537 StgWord i;
538 StgTRecChunk *tc = (StgTRecChunk *)p;
539 TRecEntry *e = &(tc -> entries[0]);
540 thread_(&tc->prev_chunk);
541 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
542 thread_(&e->tvar);
543 thread(&e->expected_value);
544 thread(&e->new_value);
545 }
546 continue;
547 }
548
549 default:
550 barf("update_fwd_large: unknown/strange object %d", (int)(info->type));
551 }
552 }
553 }
554
555 // ToDo: too big to inline
556 static /* STATIC_INLINE */ StgPtr
557 thread_obj (StgInfoTable *info, StgPtr p)
558 {
559 switch (info->type) {
560 case THUNK_0_1:
561 return p + sizeofW(StgThunk) + 1;
562
563 case FUN_0_1:
564 case CONSTR_0_1:
565 return p + sizeofW(StgHeader) + 1;
566
567 case FUN_1_0:
568 case CONSTR_1_0:
569 thread(&((StgClosure *)p)->payload[0]);
570 return p + sizeofW(StgHeader) + 1;
571
572 case THUNK_1_0:
573 thread(&((StgThunk *)p)->payload[0]);
574 return p + sizeofW(StgThunk) + 1;
575
576 case THUNK_0_2:
577 return p + sizeofW(StgThunk) + 2;
578
579 case FUN_0_2:
580 case CONSTR_0_2:
581 return p + sizeofW(StgHeader) + 2;
582
583 case THUNK_1_1:
584 thread(&((StgThunk *)p)->payload[0]);
585 return p + sizeofW(StgThunk) + 2;
586
587 case FUN_1_1:
588 case CONSTR_1_1:
589 thread(&((StgClosure *)p)->payload[0]);
590 return p + sizeofW(StgHeader) + 2;
591
592 case THUNK_2_0:
593 thread(&((StgThunk *)p)->payload[0]);
594 thread(&((StgThunk *)p)->payload[1]);
595 return p + sizeofW(StgThunk) + 2;
596
597 case FUN_2_0:
598 case CONSTR_2_0:
599 thread(&((StgClosure *)p)->payload[0]);
600 thread(&((StgClosure *)p)->payload[1]);
601 return p + sizeofW(StgHeader) + 2;
602
603 case BCO: {
604 StgBCO *bco = (StgBCO *)p;
605 thread_(&bco->instrs);
606 thread_(&bco->literals);
607 thread_(&bco->ptrs);
608 return p + bco_sizeW(bco);
609 }
610
611 case THUNK:
612 {
613 StgPtr end;
614
615 end = (P_)((StgThunk *)p)->payload +
616 info->layout.payload.ptrs;
617 for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
618 thread((StgClosure **)p);
619 }
620 return p + info->layout.payload.nptrs;
621 }
622
623 case FUN:
624 case CONSTR:
625 case STABLE_NAME:
626 case IND_PERM:
627 case MUT_VAR_CLEAN:
628 case MUT_VAR_DIRTY:
629 case CAF_BLACKHOLE:
630 case BLACKHOLE:
631 {
632 StgPtr end;
633
634 end = (P_)((StgClosure *)p)->payload +
635 info->layout.payload.ptrs;
636 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
637 thread((StgClosure **)p);
638 }
639 return p + info->layout.payload.nptrs;
640 }
641
642 case WEAK:
643 {
644 StgWeak *w = (StgWeak *)p;
645 thread(&w->cfinalizer);
646 thread(&w->key);
647 thread(&w->value);
648 thread(&w->finalizer);
649 if (w->link != NULL) {
650 thread_(&w->link);
651 }
652 return p + sizeofW(StgWeak);
653 }
654
655 case MVAR_CLEAN:
656 case MVAR_DIRTY:
657 {
658 StgMVar *mvar = (StgMVar *)p;
659 thread_(&mvar->head);
660 thread_(&mvar->tail);
661 thread(&mvar->value);
662 return p + sizeofW(StgMVar);
663 }
664
665 case IND_OLDGEN:
666 case IND_OLDGEN_PERM:
667 thread(&((StgInd *)p)->indirectee);
668 return p + sizeofW(StgInd);
669
670 case THUNK_SELECTOR:
671 {
672 StgSelector *s = (StgSelector *)p;
673 thread(&s->selectee);
674 return p + THUNK_SELECTOR_sizeW();
675 }
676
677 case AP_STACK:
678 return thread_AP_STACK((StgAP_STACK *)p);
679
680 case PAP:
681 return thread_PAP((StgPAP *)p);
682
683 case AP:
684 return thread_AP((StgAP *)p);
685
686 case ARR_WORDS:
687 return p + arr_words_sizeW((StgArrWords *)p);
688
689 case MUT_ARR_PTRS_CLEAN:
690 case MUT_ARR_PTRS_DIRTY:
691 case MUT_ARR_PTRS_FROZEN:
692 case MUT_ARR_PTRS_FROZEN0:
693 // follow everything
694 {
695 StgPtr next;
696
697 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
698 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
699 thread((StgClosure **)p);
700 }
701 return p;
702 }
703
704 case TSO:
705 return thread_TSO((StgTSO *)p);
706
707 case TVAR_WATCH_QUEUE:
708 {
709 StgTVarWatchQueue *wq = (StgTVarWatchQueue *)p;
710 thread_(&wq->closure);
711 thread_(&wq->next_queue_entry);
712 thread_(&wq->prev_queue_entry);
713 return p + sizeofW(StgTVarWatchQueue);
714 }
715
716 case TVAR:
717 {
718 StgTVar *tvar = (StgTVar *)p;
719 thread((void *)&tvar->current_value);
720 thread((void *)&tvar->first_watch_queue_entry);
721 return p + sizeofW(StgTVar);
722 }
723
724 case TREC_HEADER:
725 {
726 StgTRecHeader *trec = (StgTRecHeader *)p;
727 thread_(&trec->enclosing_trec);
728 thread_(&trec->current_chunk);
729 thread_(&trec->invariants_to_check);
730 return p + sizeofW(StgTRecHeader);
731 }
732
733 case TREC_CHUNK:
734 {
735 StgWord i;
736 StgTRecChunk *tc = (StgTRecChunk *)p;
737 TRecEntry *e = &(tc -> entries[0]);
738 thread_(&tc->prev_chunk);
739 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
740 thread_(&e->tvar);
741 thread(&e->expected_value);
742 thread(&e->new_value);
743 }
744 return p + sizeofW(StgTRecChunk);
745 }
746
747 case ATOMIC_INVARIANT:
748 {
749 StgAtomicInvariant *invariant = (StgAtomicInvariant *)p;
750 thread_(&invariant->code);
751 thread_(&invariant->last_execution);
752 return p + sizeofW(StgAtomicInvariant);
753 }
754
755 case INVARIANT_CHECK_QUEUE:
756 {
757 StgInvariantCheckQueue *queue = (StgInvariantCheckQueue *)p;
758 thread_(&queue->invariant);
759 thread_(&queue->my_execution);
760 thread_(&queue->next_queue_entry);
761 return p + sizeofW(StgInvariantCheckQueue);
762 }
763
764 default:
765 barf("update_fwd: unknown/strange object %d", (int)(info->type));
766 return NULL;
767 }
768 }
769
770 static void
771 update_fwd( bdescr *blocks )
772 {
773 StgPtr p;
774 bdescr *bd;
775 StgInfoTable *info;
776
777 bd = blocks;
778
779 // cycle through all the blocks in the step
780 for (; bd != NULL; bd = bd->link) {
781 p = bd->start;
782
783 // linearly scan the objects in this block
784 while (p < bd->free) {
785 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
786 info = get_itbl((StgClosure *)p);
787 p = thread_obj(info, p);
788 }
789 }
790 }
791
792 static void
793 update_fwd_compact( bdescr *blocks )
794 {
795 StgPtr p, q, free;
796 #if 0
797 StgWord m;
798 #endif
799 bdescr *bd, *free_bd;
800 StgInfoTable *info;
801 nat size;
802 StgWord iptr;
803
804 bd = blocks;
805 free_bd = blocks;
806 free = free_bd->start;
807
808 // cycle through all the blocks in the step
809 for (; bd != NULL; bd = bd->link) {
810 p = bd->start;
811
812 while (p < bd->free ) {
813
814 while ( p < bd->free && !is_marked(p,bd) ) {
815 p++;
816 }
817 if (p >= bd->free) {
818 break;
819 }
820
821 #if 0
822 next:
823 m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
824 m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
825
826 while ( p < bd->free ) {
827
828 if ((m & 1) == 0) {
829 m >>= 1;
830 p++;
831 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
832 goto next;
833 } else {
834 continue;
835 }
836 }
837 #endif
838
839 // Problem: we need to know the destination for this cell
840 // in order to unthread its info pointer. But we can't
841 // know the destination without the size, because we may
842 // spill into the next block. So we have to run down the
843 // threaded list and get the info ptr first.
844 //
845 // ToDo: one possible avenue of attack is to use the fact
846 // that if (p&BLOCK_MASK) >= (free&BLOCK_MASK), then we
847 // definitely have enough room. Also see bug #1147.
848 iptr = get_threaded_info(p);
849 info = INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)iptr));
850
851 q = p;
852
853 p = thread_obj(info, p);
854
855 size = p - q;
856 if (free + size > free_bd->start + BLOCK_SIZE_W) {
857 // unset the next bit in the bitmap to indicate that
858 // this object needs to be pushed into the next
859 // block. This saves us having to run down the
860 // threaded info pointer list twice during the next pass.
861 unmark(q+1,bd);
862 free_bd = free_bd->link;
863 free = free_bd->start;
864 } else {
865 ASSERT(is_marked(q+1,bd));
866 }
867
868 unthread(q,(StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
869 free += size;
870 #if 0
871 goto next;
872 #endif
873 }
874 }
875 }
876
877 static nat
878 update_bkwd_compact( step *stp )
879 {
880 StgPtr p, free;
881 #if 0
882 StgWord m;
883 #endif
884 bdescr *bd, *free_bd;
885 StgInfoTable *info;
886 nat size, free_blocks;
887 StgWord iptr;
888
889 bd = free_bd = stp->old_blocks;
890 free = free_bd->start;
891 free_blocks = 1;
892
893 // cycle through all the blocks in the step
894 for (; bd != NULL; bd = bd->link) {
895 p = bd->start;
896
897 while (p < bd->free ) {
898
899 while ( p < bd->free && !is_marked(p,bd) ) {
900 p++;
901 }
902 if (p >= bd->free) {
903 break;
904 }
905
906 #if 0
907 next:
908 m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
909 m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
910
911 while ( p < bd->free ) {
912
913 if ((m & 1) == 0) {
914 m >>= 1;
915 p++;
916 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
917 goto next;
918 } else {
919 continue;
920 }
921 }
922 #endif
923
924 if (!is_marked(p+1,bd)) {
925 // don't forget to update the free ptr in the block desc.
926 free_bd->free = free;
927 free_bd = free_bd->link;
928 free = free_bd->start;
929 free_blocks++;
930 }
931
932 iptr = get_threaded_info(p);
933 unthread(p, (StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
934 ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)((StgClosure *)p)->header.info));
935 info = get_itbl((StgClosure *)p);
936 size = closure_sizeW_((StgClosure *)p,info);
937
938 if (free != p) {
939 move(free,p,size);
940 }
941
942 // relocate TSOs
943 if (info->type == TSO) {
944 move_TSO((StgTSO *)p, (StgTSO *)free);
945 }
946
947 free += size;
948 p += size;
949 #if 0
950 goto next;
951 #endif
952 }
953 }
954
955 // free the remaining blocks and count what's left.
956 free_bd->free = free;
957 if (free_bd->link != NULL) {
958 freeChain(free_bd->link);
959 free_bd->link = NULL;
960 }
961
962 return free_blocks;
963 }
964
965 void
966 compact(StgClosure *static_objects)
967 {
968 nat g, s, blocks;
969 step *stp;
970
971 // 1. thread the roots
972 markCapabilities((evac_fn)thread_root, NULL);
973
974 // the weak pointer lists...
975 if (weak_ptr_list != NULL) {
976 thread((void *)&weak_ptr_list);
977 }
978 if (old_weak_ptr_list != NULL) {
979 thread((void *)&old_weak_ptr_list); // tmp
980 }
981
982 // mutable lists
983 for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
984 bdescr *bd;
985 StgPtr p;
986 nat n;
987 for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
988 for (p = bd->start; p < bd->free; p++) {
989 thread((StgClosure **)p);
990 }
991 }
992 for (n = 0; n < n_capabilities; n++) {
993 for (bd = capabilities[n].mut_lists[g];
994 bd != NULL; bd = bd->link) {
995 for (p = bd->start; p < bd->free; p++) {
996 thread((StgClosure **)p);
997 }
998 }
999 }
1000 }
1001
1002 // the global thread list
1003 for (s = 0; s < total_steps; s++) {
1004 thread((void *)&all_steps[s].threads);
1005 }
1006
1007 // any threads resurrected during this GC
1008 thread((void *)&resurrected_threads);
1009
1010 // the blackhole queue
1011 thread((void *)&blackhole_queue);
1012
1013 // the task list
1014 {
1015 Task *task;
1016 for (task = all_tasks; task != NULL; task = task->all_link) {
1017 if (task->tso) {
1018 thread_(&task->tso);
1019 }
1020 }
1021 }
1022
1023 // the static objects
1024 thread_static(static_objects /* ToDo: ok? */);
1025
1026 // the stable pointer table
1027 threadStablePtrTable((evac_fn)thread_root, NULL);
1028
1029 // the CAF list (used by GHCi)
1030 markCAFs((evac_fn)thread_root, NULL);
1031
1032 // 2. update forward ptrs
1033 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1034 for (s = 0; s < generations[g].n_steps; s++) {
1035 if (g==0 && s ==0) continue;
1036 stp = &generations[g].steps[s];
1037 debugTrace(DEBUG_gc, "update_fwd: %d.%d",
1038 stp->gen->no, stp->no);
1039
1040 update_fwd(stp->blocks);
1041 update_fwd_large(stp->scavenged_large_objects);
1042 if (g == RtsFlags.GcFlags.generations-1 && stp->old_blocks != NULL) {
1043 debugTrace(DEBUG_gc, "update_fwd: %d.%d (compact)",
1044 stp->gen->no, stp->no);
1045 update_fwd_compact(stp->old_blocks);
1046 }
1047 }
1048 }
1049
1050 // 3. update backward ptrs
1051 stp = &oldest_gen->steps[0];
1052 if (stp->old_blocks != NULL) {
1053 blocks = update_bkwd_compact(stp);
1054 debugTrace(DEBUG_gc,
1055 "update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)",
1056 stp->gen->no, stp->no,
1057 stp->n_old_blocks, blocks);
1058 stp->n_old_blocks = blocks;
1059 }
1060 }