← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to rts/sm/Compact.c

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

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