update copyrights in rts/sm
[ghc.git] / rts / sm / Compact.c
1 /* -----------------------------------------------------------------------------
2 *
3 * (c) The GHC Team 2001-2008
4 *
5 * Compacting garbage collector
6 *
7 * Documentation on the architecture of the Garbage Collector can be
8 * found in the online commentary:
9 *
10 * http://hackage.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/GC
11 *
12 * ---------------------------------------------------------------------------*/
13
14 #include "PosixSource.h"
15 #include "Rts.h"
16 #include "RtsUtils.h"
17 #include "RtsFlags.h"
18 #include "OSThreads.h"
19 #include "BlockAlloc.h"
20 #include "MBlock.h"
21 #include "GC.h"
22 #include "Compact.h"
23 #include "Schedule.h"
24 #include "Apply.h"
25 #include "Trace.h"
26
27 // Turn off inlining when debugging - it obfuscates things
28 #ifdef DEBUG
29 # undef STATIC_INLINE
30 # define STATIC_INLINE static
31 #endif
32
33 /* ----------------------------------------------------------------------------
34 Threading / unthreading pointers.
35
36 The basic idea here is to chain together all the fields pointing at
37 a particular object, with the root of the chain in the object's
38 info table field. The original contents of the info pointer goes
39 at the end of the chain.
40
41 Adding a new field to the chain is a matter of swapping the
42 contents of the field with the contents of the object's info table
43 field.
44
45 To unthread the chain, we walk down it updating all the fields on
46 the chain with the new location of the object. We stop when we
47 reach the info pointer at the end.
48
49 The main difficulty here is that we need to be able to identify the
50 info pointer at the end of the chain. We can't use the low bits of
51 the pointer for this; they are already being used for
52 pointer-tagging. What's more, we need to retain the
53 pointer-tagging tag bits on each pointer during the
54 threading/unthreading process.
55
56 Our solution is as follows:
57 - an info pointer (chain length zero) is identified by having tag 0
58 - in a threaded chain of length > 0:
59 - the pointer-tagging tag bits are attached to the info pointer
60 - the first entry in the chain has tag 1
61 - second and subsequent entries in the chain have tag 2
62
63 This exploits the fact that the tag on each pointer to a given
64 closure is normally the same (if they are not the same, then
65 presumably the tag is not essential and it therefore doesn't matter
66 if we throw away some of the tags).
67 ------------------------------------------------------------------------- */
68
69 STATIC_INLINE void
70 thread (StgClosure **p)
71 {
72 StgClosure *q0;
73 StgPtr q;
74 StgWord iptr;
75 bdescr *bd;
76
77 q0 = *p;
78 q = (StgPtr)UNTAG_CLOSURE(q0);
79
80 // It doesn't look like a closure at the moment, because the info
81 // ptr is possibly threaded:
82 // ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
83
84 if (HEAP_ALLOCED(q)) {
85 bd = Bdescr(q);
86 // a handy way to discover whether the ptr is into the
87 // compacted area of the old gen, is that the EVACUATED flag
88 // is zero (it's non-zero for all the other areas of live
89 // memory).
90 if ((bd->flags & BF_EVACUATED) == 0)
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(UNTAG_CLOSURE((StgClosure *)r)));
173 return r;
174 }
175 case 2:
176 q = *(StgPtr)(q-2);
177 goto loop;
178 default:
179 barf("get_threaded_info");
180 }
181 }
182
183 // A word-aligned memmove will be faster for small objects than libc's or gcc's.
184 // Remember, the two regions *might* overlap, but: to <= from.
185 STATIC_INLINE void
186 move(StgPtr to, StgPtr from, nat size)
187 {
188 for(; size > 0; --size) {
189 *to++ = *from++;
190 }
191 }
192
193 static void
194 thread_static( StgClosure* p )
195 {
196 const StgInfoTable *info;
197
198 // keep going until we've threaded all the objects on the linked
199 // list...
200 while (p != END_OF_STATIC_LIST) {
201
202 info = get_itbl(p);
203 switch (info->type) {
204
205 case IND_STATIC:
206 thread(&((StgInd *)p)->indirectee);
207 p = *IND_STATIC_LINK(p);
208 continue;
209
210 case THUNK_STATIC:
211 p = *THUNK_STATIC_LINK(p);
212 continue;
213 case FUN_STATIC:
214 p = *FUN_STATIC_LINK(p);
215 continue;
216 case CONSTR_STATIC:
217 p = *STATIC_LINK(info,p);
218 continue;
219
220 default:
221 barf("thread_static: strange closure %d", (int)(info->type));
222 }
223
224 }
225 }
226
227 STATIC_INLINE void
228 thread_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
229 {
230 nat i, b;
231 StgWord bitmap;
232
233 b = 0;
234 bitmap = large_bitmap->bitmap[b];
235 for (i = 0; i < size; ) {
236 if ((bitmap & 1) == 0) {
237 thread((StgClosure **)p);
238 }
239 i++;
240 p++;
241 if (i % BITS_IN(W_) == 0) {
242 b++;
243 bitmap = large_bitmap->bitmap[b];
244 } else {
245 bitmap = bitmap >> 1;
246 }
247 }
248 }
249
250 STATIC_INLINE StgPtr
251 thread_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
252 {
253 StgPtr p;
254 StgWord bitmap;
255 nat size;
256
257 p = (StgPtr)args;
258 switch (fun_info->f.fun_type) {
259 case ARG_GEN:
260 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
261 size = BITMAP_SIZE(fun_info->f.b.bitmap);
262 goto small_bitmap;
263 case ARG_GEN_BIG:
264 size = GET_FUN_LARGE_BITMAP(fun_info)->size;
265 thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
266 p += size;
267 break;
268 default:
269 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
270 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
271 small_bitmap:
272 while (size > 0) {
273 if ((bitmap & 1) == 0) {
274 thread((StgClosure **)p);
275 }
276 p++;
277 bitmap = bitmap >> 1;
278 size--;
279 }
280 break;
281 }
282 return p;
283 }
284
285 static void
286 thread_stack(StgPtr p, StgPtr stack_end)
287 {
288 const StgRetInfoTable* info;
289 StgWord bitmap;
290 nat size;
291
292 // highly similar to scavenge_stack, but we do pointer threading here.
293
294 while (p < stack_end) {
295
296 // *p must be the info pointer of an activation
297 // record. All activation records have 'bitmap' style layout
298 // info.
299 //
300 info = get_ret_itbl((StgClosure *)p);
301
302 switch (info->i.type) {
303
304 // Dynamic bitmap: the mask is stored on the stack
305 case RET_DYN:
306 {
307 StgWord dyn;
308 dyn = ((StgRetDyn *)p)->liveness;
309
310 // traverse the bitmap first
311 bitmap = RET_DYN_LIVENESS(dyn);
312 p = (P_)&((StgRetDyn *)p)->payload[0];
313 size = RET_DYN_BITMAP_SIZE;
314 while (size > 0) {
315 if ((bitmap & 1) == 0) {
316 thread((StgClosure **)p);
317 }
318 p++;
319 bitmap = bitmap >> 1;
320 size--;
321 }
322
323 // skip over the non-ptr words
324 p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
325
326 // follow the ptr words
327 for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
328 thread((StgClosure **)p);
329 p++;
330 }
331 continue;
332 }
333
334 // small bitmap (<= 32 entries, or 64 on a 64-bit machine)
335 case CATCH_RETRY_FRAME:
336 case CATCH_STM_FRAME:
337 case ATOMICALLY_FRAME:
338 case UPDATE_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 == BlockedOnException
476 ) {
477 thread_(&tso->block_info.closure);
478 }
479 thread_(&tso->blocked_exceptions);
480
481 thread_(&tso->trec);
482
483 thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
484 return (StgPtr)tso + tso_sizeW(tso);
485 }
486
487
488 static void
489 update_fwd_large( bdescr *bd )
490 {
491 StgPtr p;
492 const StgInfoTable* info;
493
494 for (; bd != NULL; bd = bd->link) {
495
496 p = bd->start;
497 info = get_itbl((StgClosure *)p);
498
499 switch (info->type) {
500
501 case ARR_WORDS:
502 // nothing to follow
503 continue;
504
505 case MUT_ARR_PTRS_CLEAN:
506 case MUT_ARR_PTRS_DIRTY:
507 case MUT_ARR_PTRS_FROZEN:
508 case MUT_ARR_PTRS_FROZEN0:
509 // follow everything
510 {
511 StgPtr next;
512
513 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
514 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
515 thread((StgClosure **)p);
516 }
517 continue;
518 }
519
520 case TSO:
521 thread_TSO((StgTSO *)p);
522 continue;
523
524 case AP_STACK:
525 thread_AP_STACK((StgAP_STACK *)p);
526 continue;
527
528 case PAP:
529 thread_PAP((StgPAP *)p);
530 continue;
531
532 case TREC_CHUNK:
533 {
534 StgWord i;
535 StgTRecChunk *tc = (StgTRecChunk *)p;
536 TRecEntry *e = &(tc -> entries[0]);
537 thread_(&tc->prev_chunk);
538 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
539 thread_(&e->tvar);
540 thread(&e->expected_value);
541 thread(&e->new_value);
542 }
543 continue;
544 }
545
546 default:
547 barf("update_fwd_large: unknown/strange object %d", (int)(info->type));
548 }
549 }
550 }
551
552 // ToDo: too big to inline
553 static /* STATIC_INLINE */ StgPtr
554 thread_obj (StgInfoTable *info, StgPtr p)
555 {
556 switch (info->type) {
557 case THUNK_0_1:
558 return p + sizeofW(StgThunk) + 1;
559
560 case FUN_0_1:
561 case CONSTR_0_1:
562 return p + sizeofW(StgHeader) + 1;
563
564 case FUN_1_0:
565 case CONSTR_1_0:
566 thread(&((StgClosure *)p)->payload[0]);
567 return p + sizeofW(StgHeader) + 1;
568
569 case THUNK_1_0:
570 thread(&((StgThunk *)p)->payload[0]);
571 return p + sizeofW(StgThunk) + 1;
572
573 case THUNK_0_2:
574 return p + sizeofW(StgThunk) + 2;
575
576 case FUN_0_2:
577 case CONSTR_0_2:
578 return p + sizeofW(StgHeader) + 2;
579
580 case THUNK_1_1:
581 thread(&((StgThunk *)p)->payload[0]);
582 return p + sizeofW(StgThunk) + 2;
583
584 case FUN_1_1:
585 case CONSTR_1_1:
586 thread(&((StgClosure *)p)->payload[0]);
587 return p + sizeofW(StgHeader) + 2;
588
589 case THUNK_2_0:
590 thread(&((StgThunk *)p)->payload[0]);
591 thread(&((StgThunk *)p)->payload[1]);
592 return p + sizeofW(StgThunk) + 2;
593
594 case FUN_2_0:
595 case CONSTR_2_0:
596 thread(&((StgClosure *)p)->payload[0]);
597 thread(&((StgClosure *)p)->payload[1]);
598 return p + sizeofW(StgHeader) + 2;
599
600 case BCO: {
601 StgBCO *bco = (StgBCO *)p;
602 thread_(&bco->instrs);
603 thread_(&bco->literals);
604 thread_(&bco->ptrs);
605 return p + bco_sizeW(bco);
606 }
607
608 case THUNK:
609 {
610 StgPtr end;
611
612 end = (P_)((StgThunk *)p)->payload +
613 info->layout.payload.ptrs;
614 for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
615 thread((StgClosure **)p);
616 }
617 return p + info->layout.payload.nptrs;
618 }
619
620 case FUN:
621 case CONSTR:
622 case STABLE_NAME:
623 case IND_PERM:
624 case MUT_VAR_CLEAN:
625 case MUT_VAR_DIRTY:
626 case CAF_BLACKHOLE:
627 case SE_CAF_BLACKHOLE:
628 case SE_BLACKHOLE:
629 case BLACKHOLE:
630 {
631 StgPtr end;
632
633 end = (P_)((StgClosure *)p)->payload +
634 info->layout.payload.ptrs;
635 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
636 thread((StgClosure **)p);
637 }
638 return p + info->layout.payload.nptrs;
639 }
640
641 case WEAK:
642 {
643 StgWeak *w = (StgWeak *)p;
644 thread(&w->key);
645 thread(&w->value);
646 thread(&w->finalizer);
647 if (w->link != NULL) {
648 thread_(&w->link);
649 }
650 return p + sizeofW(StgWeak);
651 }
652
653 case MVAR_CLEAN:
654 case MVAR_DIRTY:
655 {
656 StgMVar *mvar = (StgMVar *)p;
657 thread_(&mvar->head);
658 thread_(&mvar->tail);
659 thread(&mvar->value);
660 return p + sizeofW(StgMVar);
661 }
662
663 case IND_OLDGEN:
664 case IND_OLDGEN_PERM:
665 thread(&((StgInd *)p)->indirectee);
666 return p + sizeofW(StgInd);
667
668 case THUNK_SELECTOR:
669 {
670 StgSelector *s = (StgSelector *)p;
671 thread(&s->selectee);
672 return p + THUNK_SELECTOR_sizeW();
673 }
674
675 case AP_STACK:
676 return thread_AP_STACK((StgAP_STACK *)p);
677
678 case PAP:
679 return thread_PAP((StgPAP *)p);
680
681 case AP:
682 return thread_AP((StgAP *)p);
683
684 case ARR_WORDS:
685 return p + arr_words_sizeW((StgArrWords *)p);
686
687 case MUT_ARR_PTRS_CLEAN:
688 case MUT_ARR_PTRS_DIRTY:
689 case MUT_ARR_PTRS_FROZEN:
690 case MUT_ARR_PTRS_FROZEN0:
691 // follow everything
692 {
693 StgPtr next;
694
695 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
696 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
697 thread((StgClosure **)p);
698 }
699 return p;
700 }
701
702 case TSO:
703 return thread_TSO((StgTSO *)p);
704
705 case TVAR_WATCH_QUEUE:
706 {
707 StgTVarWatchQueue *wq = (StgTVarWatchQueue *)p;
708 thread_(&wq->closure);
709 thread_(&wq->next_queue_entry);
710 thread_(&wq->prev_queue_entry);
711 return p + sizeofW(StgTVarWatchQueue);
712 }
713
714 case TVAR:
715 {
716 StgTVar *tvar = (StgTVar *)p;
717 thread((void *)&tvar->current_value);
718 thread((void *)&tvar->first_watch_queue_entry);
719 return p + sizeofW(StgTVar);
720 }
721
722 case TREC_HEADER:
723 {
724 StgTRecHeader *trec = (StgTRecHeader *)p;
725 thread_(&trec->enclosing_trec);
726 thread_(&trec->current_chunk);
727 thread_(&trec->invariants_to_check);
728 return p + sizeofW(StgTRecHeader);
729 }
730
731 case TREC_CHUNK:
732 {
733 StgWord i;
734 StgTRecChunk *tc = (StgTRecChunk *)p;
735 TRecEntry *e = &(tc -> entries[0]);
736 thread_(&tc->prev_chunk);
737 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
738 thread_(&e->tvar);
739 thread(&e->expected_value);
740 thread(&e->new_value);
741 }
742 return p + sizeofW(StgTRecChunk);
743 }
744
745 case ATOMIC_INVARIANT:
746 {
747 StgAtomicInvariant *invariant = (StgAtomicInvariant *)p;
748 thread_(&invariant->code);
749 thread_(&invariant->last_execution);
750 return p + sizeofW(StgAtomicInvariant);
751 }
752
753 case INVARIANT_CHECK_QUEUE:
754 {
755 StgInvariantCheckQueue *queue = (StgInvariantCheckQueue *)p;
756 thread_(&queue->invariant);
757 thread_(&queue->my_execution);
758 thread_(&queue->next_queue_entry);
759 return p + sizeofW(StgInvariantCheckQueue);
760 }
761
762 default:
763 barf("update_fwd: unknown/strange object %d", (int)(info->type));
764 return NULL;
765 }
766 }
767
768 static void
769 update_fwd( bdescr *blocks )
770 {
771 StgPtr p;
772 bdescr *bd;
773 StgInfoTable *info;
774
775 bd = blocks;
776
777 // cycle through all the blocks in the step
778 for (; bd != NULL; bd = bd->link) {
779 p = bd->start;
780
781 // linearly scan the objects in this block
782 while (p < bd->free) {
783 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
784 info = get_itbl((StgClosure *)p);
785 p = thread_obj(info, p);
786 }
787 }
788 }
789
790 static void
791 update_fwd_compact( bdescr *blocks )
792 {
793 StgPtr p, q, free;
794 #if 0
795 StgWord m;
796 #endif
797 bdescr *bd, *free_bd;
798 StgInfoTable *info;
799 nat size;
800 StgWord iptr;
801
802 bd = blocks;
803 free_bd = blocks;
804 free = free_bd->start;
805
806 // cycle through all the blocks in the step
807 for (; bd != NULL; bd = bd->link) {
808 p = bd->start;
809
810 while (p < bd->free ) {
811
812 while ( p < bd->free && !is_marked(p,bd) ) {
813 p++;
814 }
815 if (p >= bd->free) {
816 break;
817 }
818
819 #if 0
820 next:
821 m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
822 m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
823
824 while ( p < bd->free ) {
825
826 if ((m & 1) == 0) {
827 m >>= 1;
828 p++;
829 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
830 goto next;
831 } else {
832 continue;
833 }
834 }
835 #endif
836
837 // Problem: we need to know the destination for this cell
838 // in order to unthread its info pointer. But we can't
839 // know the destination without the size, because we may
840 // spill into the next block. So we have to run down the
841 // threaded list and get the info ptr first.
842 //
843 // ToDo: one possible avenue of attack is to use the fact
844 // that if (p&BLOCK_MASK) >= (free&BLOCK_MASK), then we
845 // definitely have enough room. Also see bug #1147.
846 iptr = get_threaded_info(p);
847 info = INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)iptr));
848
849 q = p;
850
851 p = thread_obj(info, p);
852
853 size = p - q;
854 if (free + size > free_bd->start + BLOCK_SIZE_W) {
855 // unset the next bit in the bitmap to indicate that
856 // this object needs to be pushed into the next
857 // block. This saves us having to run down the
858 // threaded info pointer list twice during the next pass.
859 unmark(q+1,bd);
860 free_bd = free_bd->link;
861 free = free_bd->start;
862 } else {
863 ASSERT(is_marked(q+1,bd));
864 }
865
866 unthread(q,(StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
867 free += size;
868 #if 0
869 goto next;
870 #endif
871 }
872 }
873 }
874
875 static nat
876 update_bkwd_compact( step *stp )
877 {
878 StgPtr p, free;
879 #if 0
880 StgWord m;
881 #endif
882 bdescr *bd, *free_bd;
883 StgInfoTable *info;
884 nat size, free_blocks;
885 StgWord iptr;
886
887 bd = free_bd = stp->old_blocks;
888 free = free_bd->start;
889 free_blocks = 1;
890
891 // cycle through all the blocks in the step
892 for (; bd != NULL; bd = bd->link) {
893 p = bd->start;
894
895 while (p < bd->free ) {
896
897 while ( p < bd->free && !is_marked(p,bd) ) {
898 p++;
899 }
900 if (p >= bd->free) {
901 break;
902 }
903
904 #if 0
905 next:
906 m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
907 m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
908
909 while ( p < bd->free ) {
910
911 if ((m & 1) == 0) {
912 m >>= 1;
913 p++;
914 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
915 goto next;
916 } else {
917 continue;
918 }
919 }
920 #endif
921
922 if (!is_marked(p+1,bd)) {
923 // don't forget to update the free ptr in the block desc.
924 free_bd->free = free;
925 free_bd = free_bd->link;
926 free = free_bd->start;
927 free_blocks++;
928 }
929
930 iptr = get_threaded_info(p);
931 unthread(p, (StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
932 ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)p)->header.info));
933 info = get_itbl((StgClosure *)p);
934 size = closure_sizeW_((StgClosure *)p,info);
935
936 if (free != p) {
937 move(free,p,size);
938 }
939
940 // relocate TSOs
941 if (info->type == TSO) {
942 move_TSO((StgTSO *)p, (StgTSO *)free);
943 }
944
945 free += size;
946 p += size;
947 #if 0
948 goto next;
949 #endif
950 }
951 }
952
953 // free the remaining blocks and count what's left.
954 free_bd->free = free;
955 if (free_bd->link != NULL) {
956 freeChain(free_bd->link);
957 free_bd->link = NULL;
958 }
959
960 return free_blocks;
961 }
962
963 void
964 compact(StgClosure *static_objects)
965 {
966 nat g, s, blocks;
967 step *stp;
968
969 // 1. thread the roots
970 markCapabilities((evac_fn)thread_root, NULL);
971
972 // the weak pointer lists...
973 if (weak_ptr_list != NULL) {
974 thread((void *)&weak_ptr_list);
975 }
976 if (old_weak_ptr_list != NULL) {
977 thread((void *)&old_weak_ptr_list); // tmp
978 }
979
980 // mutable lists
981 for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
982 bdescr *bd;
983 StgPtr p;
984 for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
985 for (p = bd->start; p < bd->free; p++) {
986 thread((StgClosure **)p);
987 }
988 }
989 }
990
991 // the global thread list
992 thread((void *)&all_threads);
993
994 // any threads resurrected during this GC
995 thread((void *)&resurrected_threads);
996
997 // the task list
998 {
999 Task *task;
1000 for (task = all_tasks; task != NULL; task = task->all_link) {
1001 if (task->tso) {
1002 thread_(&task->tso);
1003 }
1004 }
1005 }
1006
1007 // the static objects
1008 thread_static(static_objects /* ToDo: ok? */);
1009
1010 // the stable pointer table
1011 threadStablePtrTable((evac_fn)thread_root, NULL);
1012
1013 // the CAF list (used by GHCi)
1014 markCAFs((evac_fn)thread_root, NULL);
1015
1016 // 2. update forward ptrs
1017 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1018 for (s = 0; s < generations[g].n_steps; s++) {
1019 if (g==0 && s ==0) continue;
1020 stp = &generations[g].steps[s];
1021 debugTrace(DEBUG_gc, "update_fwd: %d.%d",
1022 stp->gen->no, stp->no);
1023
1024 update_fwd(stp->blocks);
1025 update_fwd_large(stp->scavenged_large_objects);
1026 if (g == RtsFlags.GcFlags.generations-1 && stp->old_blocks != NULL) {
1027 debugTrace(DEBUG_gc, "update_fwd: %d.%d (compact)",
1028 stp->gen->no, stp->no);
1029 update_fwd_compact(stp->old_blocks);
1030 }
1031 }
1032 }
1033
1034 // 3. update backward ptrs
1035 stp = &oldest_gen->steps[0];
1036 if (stp->old_blocks != NULL) {
1037 blocks = update_bkwd_compact(stp);
1038 debugTrace(DEBUG_gc,
1039 "update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)",
1040 stp->gen->no, stp->no,
1041 stp->n_old_blocks, blocks);
1042 stp->n_old_blocks = blocks;
1043 }
1044 }