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