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