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