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