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