Evac.c 41.2 KB
Newer Older
1
2
/* -----------------------------------------------------------------------------
 *
3
 * (c) The GHC Team 1998-2008
4
5
6
 *
 * Generational garbage collector: evacuation functions
 *
7
8
 * Documentation on the architecture of the Garbage Collector can be
 * found in the online commentary:
9
 *
10
 *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/GC
11
 *
12
13
 * ---------------------------------------------------------------------------*/

Simon Marlow's avatar
Simon Marlow committed
14
#include "PosixSource.h"
15
#include "Rts.h"
Simon Marlow's avatar
Simon Marlow committed
16

17
#include "Evac.h"
Simon Marlow's avatar
Simon Marlow committed
18
#include "Storage.h"
19
#include "GC.h"
20
#include "GCThread.h"
Simon Marlow's avatar
Simon Marlow committed
21
#include "GCTDecl.h"
22
23
#include "GCUtils.h"
#include "Compact.h"
24
#include "MarkStack.h"
25
#include "Prelude.h"
26
#include "Trace.h"
Simon Marlow's avatar
Simon Marlow committed
27
#include "LdvProfile.h"
gcampax's avatar
gcampax committed
28
#include "CNF.h"
29
#include "Scav.h"
30

31
#if defined(PROF_SPIN) && defined(THREADED_RTS) && defined(PARALLEL_GC)
32
StgWord64 whitehole_spin = 0;
33
34
#endif

35
36
#if defined(THREADED_RTS) && !defined(PARALLEL_GC)
#define evacuate(p) evacuate1(p)
37
#define evacuate_BLACKHOLE(p) evacuate_BLACKHOLE1(p)
38
#define HEAP_ALLOCED_GC(p) HEAP_ALLOCED(p)
39
40
#endif

41
#if !defined(PARALLEL_GC) || defined(PROFILING)
42
43
44
45
#define copy_tag_nolock(p, info, src, size, stp, tag) \
        copy_tag(p, info, src, size, stp, tag)
#endif

46
47
/* Used to avoid long recursion due to selector thunks
 */
48
#define MAX_THUNK_SELECTOR_DEPTH 16
49

Ben Gamari's avatar
Ben Gamari committed
50
static void eval_thunk_selector (StgClosure **q, StgSelector * p, bool);
51
52
53
54
55
STATIC_INLINE void evacuate_large(StgPtr p);

/* -----------------------------------------------------------------------------
   Allocate some space in which to copy an object.
   -------------------------------------------------------------------------- */
56

Simon Marlow's avatar
Simon Marlow committed
57
STATIC_INLINE StgPtr
58
alloc_for_copy (uint32_t size, uint32_t gen_no)
59
{
Simon Marlow's avatar
Simon Marlow committed
60
    StgPtr to;
Simon Marlow's avatar
Simon Marlow committed
61
    gen_workspace *ws;
Simon Marlow's avatar
Simon Marlow committed
62

63
    /* Find out where we're going, using the handy "to" pointer in
Simon Marlow's avatar
Simon Marlow committed
64
     * the gen of the source object.  If it turns out we need to
Simon Marlow's avatar
Simon Marlow committed
65
66
67
     * evacuate to an older generation, adjust it here (see comment
     * by evacuate()).
     */
Simon Marlow's avatar
Simon Marlow committed
68
    if (gen_no < gct->evac_gen_no) {
69
        if (gct->eager_promotion) {
Simon Marlow's avatar
Simon Marlow committed
70
            gen_no = gct->evac_gen_no;
71
        } else {
Ben Gamari's avatar
Ben Gamari committed
72
            gct->failed_to_evac = true;
73
        }
Simon Marlow's avatar
Simon Marlow committed
74
    }
75

Simon Marlow's avatar
Simon Marlow committed
76
77
    ws = &gct->gens[gen_no];  // zero memory references here

Simon Marlow's avatar
Simon Marlow committed
78
    /* chain a new block onto the to-space for the destination gen if
Simon Marlow's avatar
Simon Marlow committed
79
80
     * necessary.
     */
81
    to = ws->todo_free;
Simon Marlow's avatar
Simon Marlow committed
82
83
    ws->todo_free += size;
    if (ws->todo_free > ws->todo_lim) {
84
        to = todo_block_full(size, ws);
Simon Marlow's avatar
Simon Marlow committed
85
    }
86
    ASSERT(ws->todo_free >= ws->todo_bd->free && ws->todo_free <= ws->todo_lim);
87

Simon Marlow's avatar
Simon Marlow committed
88
89
    return to;
}
90

91
92
93
94
/* -----------------------------------------------------------------------------
   The evacuate() code
   -------------------------------------------------------------------------- */

Simon Marlow's avatar
Simon Marlow committed
95
STATIC_INLINE GNUC_ATTR_HOT void
96
copy_tag(StgClosure **p, const StgInfoTable *info,
97
         StgClosure *src, uint32_t size, uint32_t gen_no, StgWord tag)
98
99
{
    StgPtr to, from;
100
    uint32_t i;
101

Simon Marlow's avatar
Simon Marlow committed
102
    to = alloc_for_copy(size,gen_no);
103

104
105
106
    from = (StgPtr)src;
    to[0] = (W_)info;
    for (i = 1; i < size; i++) { // unroll for small i
107
        to[i] = from[i];
108
109
110
111
112
113
114
115
116
    }

//  if (to+size+2 < bd->start + BLOCK_SIZE_W) {
//      __builtin_prefetch(to + size + 2, 1);
//  }

#if defined(PARALLEL_GC)
    {
        const StgInfoTable *new_info;
117
        new_info = (const StgInfoTable *)cas((StgPtr)&src->header.info, (W_)info, MK_FORWARDING_PTR(to));
118
        if (new_info != info) {
Ben Gamari's avatar
Ben Gamari committed
119
#if defined(PROFILING)
120
121
122
123
124
125
126
127
128
129
            // We copied this object at the same time as another
            // thread.  We'll evacuate the object again and the copy
            // we just made will be discarded at the next GC, but we
            // may have copied it after the other thread called
            // SET_EVACUAEE_FOR_LDV(), which would confuse the LDV
            // profiler when it encounters this closure in
            // processHeapClosureForDead.  So we reset the LDVW field
            // here.
            LDVW(to) = 0;
#endif
130
            return evacuate(p); // does the failed_to_evac stuff
131
132
133
134
135
136
137
138
139
        } else {
            *p = TAG_CLOSURE(tag,(StgClosure*)to);
        }
    }
#else
    src->header.info = (const StgInfoTable *)MK_FORWARDING_PTR(to);
    *p = TAG_CLOSURE(tag,(StgClosure*)to);
#endif

Ben Gamari's avatar
Ben Gamari committed
140
#if defined(PROFILING)
141
142
    // We store the size of the just evacuated object in the LDV word so that
    // the profiler can guess the position of the next object later.
143
144
    // This is safe only if we are sure that no other thread evacuates
    // the object again, so we cannot use copy_tag_nolock when PROFILING.
145
146
147
148
    SET_EVACUAEE_FOR_LDV(from, size);
#endif
}

149
#if defined(PARALLEL_GC) && !defined(PROFILING)
150
STATIC_INLINE void
151
copy_tag_nolock(StgClosure **p, const StgInfoTable *info,
152
         StgClosure *src, uint32_t size, uint32_t gen_no, StgWord tag)
153
154
{
    StgPtr to, from;
155
    uint32_t i;
156

Simon Marlow's avatar
Simon Marlow committed
157
    to = alloc_for_copy(size,gen_no);
158

159
160
161
    from = (StgPtr)src;
    to[0] = (W_)info;
    for (i = 1; i < size; i++) { // unroll for small i
162
        to[i] = from[i];
163
164
    }

165
166
167
    // if somebody else reads the forwarding pointer, we better make
    // sure there's a closure at the end of it.
    write_barrier();
168
    *p = TAG_CLOSURE(tag,(StgClosure*)to);
169
170
    src->header.info = (const StgInfoTable *)MK_FORWARDING_PTR(to);

171
172
173
174
//  if (to+size+2 < bd->start + BLOCK_SIZE_W) {
//      __builtin_prefetch(to + size + 2, 1);
//  }

Ben Gamari's avatar
Ben Gamari committed
175
#if defined(PROFILING)
176
177
178
179
180
    // We store the size of the just evacuated object in the LDV word so that
    // the profiler can guess the position of the next object later.
    SET_EVACUAEE_FOR_LDV(from, size);
#endif
}
181
#endif
182

183
184
/* Special version of copy() for when we only want to copy the info
 * pointer of an object, but reserve some padding after it.  This is
185
 * used to optimise evacuation of TSOs.
186
 */
Ben Gamari's avatar
Ben Gamari committed
187
static bool
188
189
copyPart(StgClosure **p, StgClosure *src, uint32_t size_to_reserve,
         uint32_t size_to_copy, uint32_t gen_no)
190
191
{
    StgPtr to, from;
192
    uint32_t i;
193
    StgWord info;
194

195
196
#if defined(PARALLEL_GC)
spin:
197
198
        info = xchg((StgPtr)&src->header.info, (W_)&stg_WHITEHOLE_info);
        if (info == (W_)&stg_WHITEHOLE_info) {
Ben Gamari's avatar
Ben Gamari committed
199
#if defined(PROF_SPIN)
200
            whitehole_spin++;
201
#endif
202
203
            goto spin;
        }
204
    if (IS_FORWARDING_PTR(info)) {
205
206
        src->header.info = (const StgInfoTable *)info;
        evacuate(p); // does the failed_to_evac stuff
Ben Gamari's avatar
Ben Gamari committed
207
        return false;
208
209
210
211
212
    }
#else
    info = (W_)src->header.info;
#endif

Simon Marlow's avatar
Simon Marlow committed
213
    to = alloc_for_copy(size_to_reserve, gen_no);
214
215

    from = (StgPtr)src;
216
    to[0] = info;
217
    for (i = 1; i < size_to_copy; i++) { // unroll for small i
218
        to[i] = from[i];
219
    }
220

221
222
    write_barrier();
    src->header.info = (const StgInfoTable*)MK_FORWARDING_PTR(to);
223
    *p = (StgClosure *)to;
224

Ben Gamari's avatar
Ben Gamari committed
225
#if defined(PROFILING)
226
227
228
229
230
    // We store the size of the just evacuated object in the LDV word so that
    // the profiler can guess the position of the next object later.
    SET_EVACUAEE_FOR_LDV(from, size_to_reserve);
    // fill the slop
    if (size_to_reserve - size_to_copy > 0)
231
        LDV_FILL_SLOP(to + size_to_copy, (int)(size_to_reserve - size_to_copy));
232
#endif
233

Ben Gamari's avatar
Ben Gamari committed
234
    return true;
235
236
237
238
}


/* Copy wrappers that don't tag the closure after copying */
Simon Marlow's avatar
Simon Marlow committed
239
STATIC_INLINE GNUC_ATTR_HOT void
240
copy(StgClosure **p, const StgInfoTable *info,
241
     StgClosure *src, uint32_t size, uint32_t gen_no)
242
{
Simon Marlow's avatar
Simon Marlow committed
243
    copy_tag(p,info,src,size,gen_no,0);
244
245
}

246
247
248
249
/* -----------------------------------------------------------------------------
   Evacuate a large object

   This just consists of removing the object from the (doubly-linked)
Simon Marlow's avatar
Simon Marlow committed
250
   gen->large_objects list, and linking it on to the (singly-linked)
gcampax's avatar
gcampax committed
251
   gct->todo_large_objects list, from where it will be scavenged later.
252
253
254
255
256
257
258
259

   Convention: bd->flags has BF_EVACUATED set for a large object
   that has been evacuated, or unset otherwise.
   -------------------------------------------------------------------------- */

STATIC_INLINE void
evacuate_large(StgPtr p)
{
260
  bdescr *bd;
Simon Marlow's avatar
Simon Marlow committed
261
  generation *gen, *new_gen;
262
  uint32_t gen_no, new_gen_no;
Simon Marlow's avatar
Simon Marlow committed
263
  gen_workspace *ws;
264

265
  bd = Bdescr(p);
Simon Marlow's avatar
Simon Marlow committed
266
  gen = bd->gen;
Simon Marlow's avatar
Simon Marlow committed
267
  gen_no = bd->gen_no;
Simon Marlow's avatar
Simon Marlow committed
268
  ACQUIRE_SPIN_LOCK(&gen->sync);
269

270
271
  // already evacuated?
  if (bd->flags & BF_EVACUATED) {
272
273
274
    /* Don't forget to set the gct->failed_to_evac flag if we didn't get
     * the desired destination (see comments in evacuate()).
     */
Simon Marlow's avatar
Simon Marlow committed
275
    if (gen_no < gct->evac_gen_no) {
Ben Gamari's avatar
Ben Gamari committed
276
        gct->failed_to_evac = true;
277
        TICK_GC_FAILED_PROMOTION();
278
    }
Simon Marlow's avatar
Simon Marlow committed
279
    RELEASE_SPIN_LOCK(&gen->sync);
280
281
282
    return;
  }

283
  // remove from large_object list
284
285
  if (bd->u.back) {
    bd->u.back->link = bd->link;
286
  } else { // first object in the list
Simon Marlow's avatar
Simon Marlow committed
287
    gen->large_objects = bd->link;
288
289
290
291
  }
  if (bd->link) {
    bd->link->u.back = bd->u.back;
  }
292

Simon Marlow's avatar
Simon Marlow committed
293
  /* link it on to the evacuated large object list of the destination gen
294
   */
Simon Marlow's avatar
Simon Marlow committed
295
296
297
  new_gen_no = bd->dest_no;

  if (new_gen_no < gct->evac_gen_no) {
298
      if (gct->eager_promotion) {
Simon Marlow's avatar
Simon Marlow committed
299
          new_gen_no = gct->evac_gen_no;
300
      } else {
Ben Gamari's avatar
Ben Gamari committed
301
          gct->failed_to_evac = true;
302
303
304
      }
  }

Simon Marlow's avatar
Simon Marlow committed
305
306
  ws = &gct->gens[new_gen_no];
  new_gen = &generations[new_gen_no];
Simon Marlow's avatar
Simon Marlow committed
307

308
  bd->flags |= BF_EVACUATED;
Simon Marlow's avatar
Simon Marlow committed
309
  initBdescr(bd, new_gen, new_gen->to);
Simon Marlow's avatar
Simon Marlow committed
310

gcampax's avatar
gcampax committed
311
312
  // If this is a block of pinned or compact objects, we don't have to scan
  // these objects, because they aren't allowed to contain any outgoing
Simon Marlow's avatar
Simon Marlow committed
313
314
315
316
  // pointers.  For these blocks, we skip the scavenge stage and put
  // them straight on the scavenged_large_objects list.
  if (bd->flags & BF_PINNED) {
      ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS);
gcampax's avatar
gcampax committed
317

Simon Marlow's avatar
Simon Marlow committed
318
      if (new_gen != gen) { ACQUIRE_SPIN_LOCK(&new_gen->sync); }
Simon Marlow's avatar
Simon Marlow committed
319
320
      dbl_link_onto(bd, &new_gen->scavenged_large_objects);
      new_gen->n_scavenged_large_blocks += bd->blocks;
Simon Marlow's avatar
Simon Marlow committed
321
      if (new_gen != gen) { RELEASE_SPIN_LOCK(&new_gen->sync); }
Simon Marlow's avatar
Simon Marlow committed
322
323
324
325
  } else {
      bd->link = ws->todo_large_objects;
      ws->todo_large_objects = bd;
  }
326

Simon Marlow's avatar
Simon Marlow committed
327
  RELEASE_SPIN_LOCK(&gen->sync);
328
329
}

330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
/* ----------------------------------------------------------------------------
   Evacuate static objects

   When a static object is visited for the first time in this GC, it
   is chained on to the gct->static_objects list.

   evacuate_static_object (link_field, q)
     - link_field must be STATIC_LINK(q)
   ------------------------------------------------------------------------- */

STATIC_INLINE void
evacuate_static_object (StgClosure **link_field, StgClosure *q)
{
    StgWord link = (StgWord)*link_field;

    // See Note [STATIC_LINK fields] for how the link field bits work
    if ((((StgWord)(link)&STATIC_BITS) | prev_static_flag) != 3) {
        StgWord new_list_head = (StgWord)q | static_flag;
Ben Gamari's avatar
Ben Gamari committed
348
#if !defined(THREADED_RTS)
349
350
351
352
353
354
355
356
357
358
359
360
361
        *link_field = gct->static_objects;
        gct->static_objects = (StgClosure *)new_list_head;
#else
        StgWord prev;
        prev = cas((StgVolatilePtr)link_field, link,
                   (StgWord)gct->static_objects);
        if (prev == link) {
            gct->static_objects = (StgClosure *)new_list_head;
        }
#endif
    }
}

gcampax's avatar
gcampax committed
362
363
364
/* ----------------------------------------------------------------------------
   Evacuate an object inside a CompactNFData

365
366
367
   These are treated in a similar way to large objects.  We remove the block
   from the compact_objects list of the generation it is on, and link it onto
   the live_compact_objects list of the destination generation.
gcampax's avatar
gcampax committed
368
369
370
371
372
373
374
375
376
377
378
379

   It is assumed that objects in the struct live in the same generation
   as the struct itself all the time.
   ------------------------------------------------------------------------- */
STATIC_INLINE void
evacuate_compact (StgPtr p)
{
    StgCompactNFData *str;
    bdescr *bd;
    generation *gen, *new_gen;
    uint32_t gen_no, new_gen_no;

380
381
382
    // We need to find the Compact# corresponding to this pointer, because it
    // will give us the first block in the compact chain, which is the one we
    // that gets linked onto the compact_objects list.
gcampax's avatar
gcampax committed
383
384
385
386
387
388
389
390
391
392
393
394
395
    str = objectGetCompact((StgClosure*)p);
    ASSERT(get_itbl((StgClosure*)str)->type == COMPACT_NFDATA);

    bd = Bdescr((StgPtr)str);
    gen_no = bd->gen_no;

    // already evacuated? (we're about to do the same check,
    // but we avoid taking the spin-lock)
    if (bd->flags & BF_EVACUATED) {
        /* Don't forget to set the gct->failed_to_evac flag if we didn't get
         * the desired destination (see comments in evacuate()).
         */
        if (gen_no < gct->evac_gen_no) {
Ben Gamari's avatar
Ben Gamari committed
396
            gct->failed_to_evac = true;
gcampax's avatar
gcampax committed
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
            TICK_GC_FAILED_PROMOTION();
        }
        return;
    }

    gen = bd->gen;
    gen_no = bd->gen_no;
    ACQUIRE_SPIN_LOCK(&gen->sync);

    // already evacuated?
    if (bd->flags & BF_EVACUATED) {
        /* Don't forget to set the gct->failed_to_evac flag if we didn't get
         * the desired destination (see comments in evacuate()).
         */
        if (gen_no < gct->evac_gen_no) {
Ben Gamari's avatar
Ben Gamari committed
412
            gct->failed_to_evac = true;
gcampax's avatar
gcampax committed
413
414
415
416
417
418
            TICK_GC_FAILED_PROMOTION();
        }
        RELEASE_SPIN_LOCK(&gen->sync);
        return;
    }

419
    // remove from compact_objects list
gcampax's avatar
gcampax committed
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
    if (bd->u.back) {
        bd->u.back->link = bd->link;
    } else { // first object in the list
        gen->compact_objects = bd->link;
    }
    if (bd->link) {
        bd->link->u.back = bd->u.back;
    }

    /* link it on to the evacuated compact object list of the destination gen
     */
    new_gen_no = bd->dest_no;

    if (new_gen_no < gct->evac_gen_no) {
        if (gct->eager_promotion) {
            new_gen_no = gct->evac_gen_no;
        } else {
Ben Gamari's avatar
Ben Gamari committed
437
            gct->failed_to_evac = true;
gcampax's avatar
gcampax committed
438
439
440
441
442
443
444
445
446
447
448
449
450
451
        }
    }

    new_gen = &generations[new_gen_no];

    // Note: for speed we only update the generation of the first block here
    // This means that bdescr of subsequent blocks will think they are in
    // the wrong generation
    // (This should not be a problem because there is no code that checks
    // for that - the only code touching the generation of the block is
    // in the GC, and that should never see blocks other than the first)
    bd->flags |= BF_EVACUATED;
    initBdescr(bd, new_gen, new_gen->to);

452
453
454
455
456
457
458
459
460
461
    if (str->hash) {
        gen_workspace *ws = &gct->gens[new_gen_no];
        bd->link = ws->todo_large_objects;
        ws->todo_large_objects = bd;
    } else {
        if (new_gen != gen) { ACQUIRE_SPIN_LOCK(&new_gen->sync); }
        dbl_link_onto(bd, &new_gen->live_compact_objects);
        new_gen->n_live_compact_blocks += str->totalW / BLOCK_SIZE_W;
        if (new_gen != gen) { RELEASE_SPIN_LOCK(&new_gen->sync); }
    }
gcampax's avatar
gcampax committed
462
463
464
465
466
467
468
469
470
471
472
473
474

    RELEASE_SPIN_LOCK(&gen->sync);

    // Note: the object did not move in memory, because it lives
    // in pinned (BF_COMPACT) allocation, so we do not need to rewrite it
    // or muck with forwarding pointers
    // Also there is no tag to worry about on the struct (tags are used
    // for constructors and functions, but a struct is neither). There
    // might be a tag on the object pointer, but again we don't change
    // the pointer because we don't move the object so we don't need to
    // rewrite the tag.
}

475
476
477
478
479
480
/* ----------------------------------------------------------------------------
   Evacuate

   This is called (eventually) for every live object in the system.

   The caller to evacuate specifies a desired generation in the
Simon Marlow's avatar
Simon Marlow committed
481
   gct->evac_gen thread-local variable.  The following conditions apply to
482
483
484
   evacuating an object which resides in generation M when we're
   collecting up to generation N

485
   if  M >= gct->evac_gen
486
           if  M > N     do nothing
487
           else          evac to gen->to
488

Simon Marlow's avatar
Simon Marlow committed
489
   if  M < gct->evac_gen      evac to gct->evac_gen, step 0
490
491
492
493

   if the object is already evacuated, then we check which generation
   it now resides in.

Simon Marlow's avatar
Simon Marlow committed
494
495
496
   if  M >= gct->evac_gen     do nothing
   if  M <  gct->evac_gen     set gct->failed_to_evac flag to indicate that we
                         didn't manage to evacuate this object into gct->evac_gen.
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516


   OPTIMISATION NOTES:

   evacuate() is the single most important function performance-wise
   in the GC.  Various things have been tried to speed it up, but as
   far as I can tell the code generated by gcc 3.2 with -O2 is about
   as good as it's going to get.  We pass the argument to evacuate()
   in a register using the 'regparm' attribute (see the prototype for
   evacuate() near the top of this file).

   Changing evacuate() to take an (StgClosure **) rather than
   returning the new pointer seems attractive, because we can avoid
   writing back the pointer when it hasn't changed (eg. for a static
   object, or an object in a generation > N).  However, I tried it and
   it doesn't help.  One reason is that the (StgClosure **) pointer
   gets spilled to the stack inside evacuate(), resulting in far more
   extra reads/writes than we save.
   ------------------------------------------------------------------------- */

517
REGPARM1 GNUC_ATTR_HOT void
518
519
520
evacuate(StgClosure **p)
{
  bdescr *bd = NULL;
521
  uint32_t gen_no;
522
523
524
525
526
527
528
529
530
531
532
  StgClosure *q;
  const StgInfoTable *info;
  StgWord tag;

  q = *p;

loop:
  /* The tag and the pointer are split, to be merged after evacing */
  tag = GET_CLOSURE_TAG(q);
  q = UNTAG_CLOSURE(q);

533
  ASSERTM(LOOKS_LIKE_CLOSURE_PTR(q), "invalid closure, info=%p", q->header.info);
534

535
  if (!HEAP_ALLOCED_GC(q)) {
536
537
538
539
540
541
      if (!major_gc) return;

      info = get_itbl(q);
      switch (info->type) {

      case THUNK_STATIC:
542
          if (info->srt_bitmap != 0) {
543
              evacuate_static_object(THUNK_STATIC_LINK((StgClosure *)q), q);
544
545
          }
          return;
546
547

      case FUN_STATIC:
548
549
          if (info->srt_bitmap != 0) {
              evacuate_static_object(FUN_STATIC_LINK((StgClosure *)q), q);
550
551
552
          }
          return;

553
      case IND_STATIC:
554
555
556
557
          /* If q->saved_info != NULL, then it's a revertible CAF - it'll be
           * on the CAF list, so don't do anything with it here (we'll
           * scavenge it later).
           */
558
          evacuate_static_object(IND_STATIC_LINK((StgClosure *)q), q);
559
560
          return;

Simon Marlow's avatar
Simon Marlow committed
561
562
563
564
      case CONSTR:
      case CONSTR_1_0:
      case CONSTR_2_0:
      case CONSTR_1_1:
565
          evacuate_static_object(STATIC_LINK(info,(StgClosure *)q), q);
566
          return;
567

Simon Marlow's avatar
Simon Marlow committed
568
569
570
      case CONSTR_0_1:
      case CONSTR_0_2:
      case CONSTR_NOCAF:
571
572
573
574
575
          /* no need to put these on the static linked list, they don't need
           * to be scavenged.
           */
          return;

576
      default:
577
          barf("evacuate(static): strange closure type %d", (int)(info->type));
578
579
580
581
582
      }
  }

  bd = Bdescr((P_)q);

gcampax's avatar
gcampax committed
583
  if ((bd->flags & (BF_LARGE | BF_MARKED | BF_EVACUATED | BF_COMPACT)) != 0) {
584
585
586
587
588
589
590
591
592
593
      // pointer into to-space: just return it.  It might be a pointer
      // into a generation that we aren't collecting (> N), or it
      // might just be a pointer into to-space.  The latter doesn't
      // happen often, but allowing it makes certain things a bit
      // easier; e.g. scavenging an object is idempotent, so it's OK to
      // have an object on the mutable list multiple times.
      if (bd->flags & BF_EVACUATED) {
          // We aren't copying this object, so we have to check
          // whether it is already in the target generation.  (this is
          // the write barrier).
Simon Marlow's avatar
Simon Marlow committed
594
          if (bd->gen_no < gct->evac_gen_no) {
Ben Gamari's avatar
Ben Gamari committed
595
              gct->failed_to_evac = true;
596
597
598
              TICK_GC_FAILED_PROMOTION();
          }
          return;
599
600
      }

gcampax's avatar
gcampax committed
601
602
603
604
605
606
607
608
609
      // Check for compact before checking for large, this allows doing the
      // right thing for objects that are half way in the middle of the first
      // block of a compact (and would be treated as large objects even though
      // they are not)
      if (bd->flags & BF_COMPACT) {
          evacuate_compact((P_)q);
          return;
      }

610
611
612
      /* evacuate large objects by re-linking them onto a different list.
       */
      if (bd->flags & BF_LARGE) {
613
          evacuate_large((P_)q);
614
          return;
615
      }
616

Simon Marlow's avatar
Simon Marlow committed
617
      /* If the object is in a gen that we're compacting, then we
618
619
       * need to use an alternative evacuate procedure.
       */
620
621
622
      if (!is_marked((P_)q,bd)) {
          mark((P_)q,bd);
          push_mark_stack((P_)q);
623
      }
624
      return;
625
  }
626

Simon Marlow's avatar
Simon Marlow committed
627
  gen_no = bd->dest_no;
628
629
630
631
632

  info = q->header.info;
  if (IS_FORWARDING_PTR(info))
  {
    /* Already evacuated, just return the forwarding address.
Simon Marlow's avatar
Simon Marlow committed
633
     * HOWEVER: if the requested destination generation (gct->evac_gen) is
634
635
     * older than the actual generation (because the object was
     * already evacuated to a younger generation) then we have to
636
     * set the gct->failed_to_evac flag to indicate that we couldn't
637
638
     * manage to promote the object to the desired generation.
     */
639
    /*
640
641
642
643
     * Optimisation: the check is fairly expensive, but we can often
     * shortcut it if either the required generation is 0, or the
     * current object (the EVACUATED) is in a high enough generation.
     * We know that an EVACUATED always points to an object in the
Simon Marlow's avatar
Simon Marlow committed
644
     * same or an older generation.  gen is the lowest generation that the
645
     * current object would be evacuated to, so we only do the full
Simon Marlow's avatar
Simon Marlow committed
646
     * check if gen is too low.
647
648
649
     */
      StgClosure *e = (StgClosure*)UN_FORWARDING_PTR(info);
      *p = TAG_CLOSURE(tag,e);
Simon Marlow's avatar
Simon Marlow committed
650
651
      if (gen_no < gct->evac_gen_no) {  // optimisation
          if (Bdescr((P_)e)->gen_no < gct->evac_gen_no) {
Ben Gamari's avatar
Ben Gamari committed
652
              gct->failed_to_evac = true;
653
654
              TICK_GC_FAILED_PROMOTION();
          }
655
656
657
658
659
660
661
662
663
      }
      return;
  }

  switch (INFO_PTR_TO_STRUCT(info)->type) {

  case WHITEHOLE:
      goto loop;

664
  // For ints and chars of low value, save space by replacing references to
665
  //    these with closures with references to common, shared ones in the RTS.
666
667
  //
  // * Except when compiling into Windows DLLs which don't support cross-package
668
  //    data references very well.
669
  //
670
  case CONSTR_0_1:
671
  {
672
#if defined(COMPILING_WINDOWS_DLL)
Simon Marlow's avatar
Simon Marlow committed
673
      copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen_no,tag);
674
#else
675
676
      StgWord w = (StgWord)q->payload[0];
      if (info == Czh_con_info &&
677
678
679
          // unsigned, so always true:  (StgChar)w >= MIN_CHARLIKE &&
          (StgChar)w <= MAX_CHARLIKE) {
          *p =  TAG_CLOSURE(tag,
680
                            (StgClosure *)CHARLIKE_CLOSURE((StgChar)w)
681
                           );
682
683
      }
      else if (info == Izh_con_info &&
684
685
686
687
          (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
          *p = TAG_CLOSURE(tag,
                             (StgClosure *)INTLIKE_CLOSURE((StgInt)w)
                             );
688
689
      }
      else {
Simon Marlow's avatar
Simon Marlow committed
690
          copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen_no,tag);
691
      }
692
#endif
693
694
695
696
697
698
      return;
  }

  case FUN_0_1:
  case FUN_1_0:
  case CONSTR_1_0:
Simon Marlow's avatar
Simon Marlow committed
699
      copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen_no,tag);
700
701
702
703
      return;

  case THUNK_1_0:
  case THUNK_0_1:
Simon Marlow's avatar
Simon Marlow committed
704
      copy(p,info,q,sizeofW(StgThunk)+1,gen_no);
705
706
707
708
709
      return;

  case THUNK_1_1:
  case THUNK_2_0:
  case THUNK_0_2:
Ben Gamari's avatar
Ben Gamari committed
710
#if defined(NO_PROMOTE_THUNKS)
Simon Marlow's avatar
Simon Marlow committed
711
#error bitrotted
712
#endif
Simon Marlow's avatar
Simon Marlow committed
713
    copy(p,info,q,sizeofW(StgThunk)+2,gen_no);
714
715
716
717
718
719
720
    return;

  case FUN_1_1:
  case FUN_2_0:
  case FUN_0_2:
  case CONSTR_1_1:
  case CONSTR_2_0:
Simon Marlow's avatar
Simon Marlow committed
721
      copy_tag_nolock(p,info,q,sizeofW(StgHeader)+2,gen_no,tag);
722
723
724
      return;

  case CONSTR_0_2:
Simon Marlow's avatar
Simon Marlow committed
725
      copy_tag_nolock(p,info,q,sizeofW(StgHeader)+2,gen_no,tag);
726
727
728
      return;

  case THUNK:
Simon Marlow's avatar
Simon Marlow committed
729
      copy(p,info,q,thunk_sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no);
730
731
732
733
      return;

  case FUN:
  case CONSTR:
Simon Marlow's avatar
Simon Marlow committed
734
  case CONSTR_NOCAF:
Simon Marlow's avatar
Simon Marlow committed
735
      copy_tag_nolock(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no,tag);
736
737
      return;

738
739
740
741
742
743
744
745
746
747
748
749
  case BLACKHOLE:
  {
      StgClosure *r;
      const StgInfoTable *i;
      r = ((StgInd*)q)->indirectee;
      if (GET_CLOSURE_TAG(r) == 0) {
          i = r->header.info;
          if (IS_FORWARDING_PTR(i)) {
              r = (StgClosure *)UN_FORWARDING_PTR(i);
              i = r->header.info;
          }
          if (i == &stg_TSO_info
750
              || i == &stg_WHITEHOLE_info
751
752
              || i == &stg_BLOCKING_QUEUE_CLEAN_info
              || i == &stg_BLOCKING_QUEUE_DIRTY_info) {
Simon Marlow's avatar
Simon Marlow committed
753
              copy(p,info,q,sizeofW(StgInd),gen_no);
754
755
756
757
758
759
760
761
762
              return;
          }
          ASSERT(i != &stg_IND_info);
      }
      q = r;
      *p = r;
      goto loop;
  }

763
764
765
766
767
  case MUT_VAR_CLEAN:
  case MUT_VAR_DIRTY:
  case MVAR_CLEAN:
  case MVAR_DIRTY:
  case TVAR:
768
  case BLOCKING_QUEUE:
769
  case WEAK:
770
771
  case PRIM:
  case MUT_PRIM:
Simon Marlow's avatar
Simon Marlow committed
772
      copy(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no);
773
774
775
      return;

  case BCO:
Simon Marlow's avatar
Simon Marlow committed
776
      copy(p,info,q,bco_sizeW((StgBCO *)q),gen_no);
777
778
779
      return;

  case THUNK_SELECTOR:
Ben Gamari's avatar
Ben Gamari committed
780
      eval_thunk_selector(p, (StgSelector *)q, true);
781
782
783
      return;

  case IND:
784
    // follow chains of indirections, don't evacuate them
785
786
787
788
789
790
791
792
    q = ((StgInd*)q)->indirectee;
    *p = q;
    goto loop;

  case RET_BCO:
  case RET_SMALL:
  case RET_BIG:
  case UPDATE_FRAME:
793
  case UNDERFLOW_FRAME:
794
795
796
797
798
  case STOP_FRAME:
  case CATCH_FRAME:
  case CATCH_STM_FRAME:
  case CATCH_RETRY_FRAME:
  case ATOMICALLY_FRAME:
799
    // shouldn't see these
800
801
802
    barf("evacuate: stack frame at %p\n", q);

  case PAP:
Simon Marlow's avatar
Simon Marlow committed
803
      copy(p,info,q,pap_sizeW((StgPAP*)q),gen_no);
804
805
806
      return;

  case AP:
Simon Marlow's avatar
Simon Marlow committed
807
      copy(p,info,q,ap_sizeW((StgAP*)q),gen_no);
808
809
810
      return;

  case AP_STACK:
Simon Marlow's avatar
Simon Marlow committed
811
      copy(p,info,q,ap_stack_sizeW((StgAP_STACK*)q),gen_no);
812
813
814
      return;

  case ARR_WORDS:
815
      // just copy the block
siddhanathan's avatar
siddhanathan committed
816
      copy(p,info,q,arr_words_sizeW((StgArrBytes *)q),gen_no);
817
818
819
820
821
822
      return;

  case MUT_ARR_PTRS_CLEAN:
  case MUT_ARR_PTRS_DIRTY:
  case MUT_ARR_PTRS_FROZEN:
  case MUT_ARR_PTRS_FROZEN0:
823
      // just copy the block
Simon Marlow's avatar
Simon Marlow committed
824
      copy(p,info,q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),gen_no);
825
826
827
828
829
830
      return;

  case SMALL_MUT_ARR_PTRS_CLEAN:
  case SMALL_MUT_ARR_PTRS_DIRTY:
  case SMALL_MUT_ARR_PTRS_FROZEN:
  case SMALL_MUT_ARR_PTRS_FROZEN0:
831
      // just copy the block
832
      copy(p,info,q,small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs *)q),gen_no);
833
834
835
      return;

  case TSO:
Simon Marlow's avatar
Simon Marlow committed
836
      copy(p,info,q,sizeofW(StgTSO),gen_no);
837
      return;
838

839
840
841
  case STACK:
    {
      StgStack *stack = (StgStack *)q;
842

843
      /* To evacuate a small STACK, we need to adjust the stack pointer
844
845
       */
      {
846
          StgStack *new_stack;
847
          StgPtr r, s;
Ben Gamari's avatar
Ben Gamari committed
848
          bool mine;
849

850
          mine = copyPart(p,(StgClosure *)stack, stack_sizeW(stack),
Simon Marlow's avatar
Simon Marlow committed
851
                          sizeofW(StgStack), gen_no);
852
          if (mine) {
853
854
855
856
              new_stack = (StgStack *)*p;
              move_STACK(stack, new_stack);
              for (r = stack->sp, s = new_stack->sp;
                   r < stack->stack + stack->stack_size;) {
857
858
859
                  *s++ = *r++;
              }
          }
860
          return;
861
862
863
864
      }
    }

  case TREC_CHUNK:
Simon Marlow's avatar
Simon Marlow committed
865
      copy(p,info,q,sizeofW(StgTRecChunk),gen_no);
866
867
868
869
870
871
872
873
874
      return;

  default:
    barf("evacuate: strange closure type %d", (int)(INFO_PTR_TO_STRUCT(info)->type));
  }

  barf("evacuate");
}

875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
/* -----------------------------------------------------------------------------
   Evacuate a pointer that is guaranteed to point to a BLACKHOLE.

   This is used for evacuating the updatee of an update frame on the stack.  We
   want to copy the blackhole even if it has been updated by another thread and
   is now an indirection, because the original update frame still needs to
   update it.

   See also Note [upd-black-hole] in sm/Scav.c.
   -------------------------------------------------------------------------- */

void
evacuate_BLACKHOLE(StgClosure **p)
{
    bdescr *bd;
    uint32_t gen_no;
    StgClosure *q;
    const StgInfoTable *info;
    q = *p;

    // closure is required to be a heap-allocated BLACKHOLE
    ASSERT(HEAP_ALLOCED_GC(q));
    ASSERT(GET_CLOSURE_TAG(q) == 0);

    bd = Bdescr((P_)q);

901
902
903
904
905
906
907
908
909
910
    // blackholes can't be in a compact
    ASSERT((bd->flags & BF_COMPACT) == 0);

    // blackholes *can* be in a large object: when raiseAsync() creates an
    // AP_STACK the payload might be large enough to create a large object.
    // See #14497.
    if (bd->flags & BF_LARGE) {
        evacuate_large((P_)q);
        return;
    }
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
    if (bd->flags & BF_EVACUATED) {
        if (bd->gen_no < gct->evac_gen_no) {
            gct->failed_to_evac = true;
            TICK_GC_FAILED_PROMOTION();
        }
        return;
    }
    if (bd->flags & BF_MARKED) {
        if (!is_marked((P_)q,bd)) {
            mark((P_)q,bd);
            push_mark_stack((P_)q);
        }
        return;
    }
    gen_no = bd->dest_no;
    info = q->header.info;
    if (IS_FORWARDING_PTR(info))
    {
        StgClosure *e = (StgClosure*)UN_FORWARDING_PTR(info);
        *p = e;
        if (gen_no < gct->evac_gen_no) {  // optimisation
            if (Bdescr((P_)e)->gen_no < gct->evac_gen_no) {
                gct->failed_to_evac = true;
                TICK_GC_FAILED_PROMOTION();
            }
        }
        return;
    }

    ASSERT(INFO_PTR_TO_STRUCT(info)->type == BLACKHOLE);
    copy(p,info,q,sizeofW(StgInd),gen_no);
}

944
/* -----------------------------------------------------------------------------
945
   Evaluate a THUNK_SELECTOR if possible.
946

947
948
949
   p points to a THUNK_SELECTOR that we want to evaluate.  The
   result of "evaluating" it will be evacuated and a pointer to the
   to-space closure will be returned.
950

951
952
953
   If the THUNK_SELECTOR could not be evaluated (its selectee is still
   a THUNK, for example), then the THUNK_SELECTOR itself will be
   evacuated.
954
   -------------------------------------------------------------------------- */
955
956
957
958
static void
unchain_thunk_selectors(StgSelector *p, StgClosure *val)
{
    StgSelector *prev;
959

960
961
962
    prev = NULL;
    while (p)
    {
simonmar@microsoft.com's avatar
simonmar@microsoft.com committed
963
        ASSERT(p->header.info == &stg_WHITEHOLE_info);
964
        // val must be in to-space.  Not always: when we recursively
965
        // invoke eval_thunk_selector(), the recursive calls will not
966
967
        // evacuate the value (because we want to select on the value,
        // not evacuate it), so in this case val is in from-space.
968
        // ASSERT(!HEAP_ALLOCED_GC(val) || Bdescr((P_)val)->gen_no > N || (Bdescr((P_)val)->flags & BF_EVACUATED));
Simon Marlow's avatar
Simon Marlow committed
969

970
971
972
        prev = (StgSelector*)((StgClosure *)p)->payload[0];

        // Update the THUNK_SELECTOR with an indirection to the
973
974
975
976
977
978
979
980
981
982
983
984
985
        // value.  The value is still in from-space at this stage.
        //
        // (old note: Why not do upd_evacuee(q,p)?  Because we have an
        // invariant that an EVACUATED closure always points to an
        // object in the same or an older generation (required by
        // the short-cut test in the EVACUATED case, below).
        if ((StgClosure *)p == val) {
            // must be a loop; just leave a BLACKHOLE in place.  This
            // can happen when we have a chain of selectors that
            // eventually loops back on itself.  We can't leave an
            // indirection pointing to itself, and we want the program
            // to deadlock if it ever enters this closure, so
            // BLACKHOLE is correct.
986
987
988
989
990
991

            // XXX we do not have BLACKHOLEs any more; replace with
            // a THUNK_SELECTOR again.  This will go into a loop if it is
            // entered, and should result in a NonTermination exception.
            ((StgThunk *)p)->payload[0] = val;
            write_barrier();
992
            SET_INFO((StgClosure *)p, &stg_sel_0_upd_info);
993
994
995
        } else {
            ((StgInd *)p)->indirectee = val;
            write_barrier();
996
            SET_INFO((StgClosure *)p, &stg_IND_info);
997
        }
998
999
1000
1001
1002
1003
1004
1005

        // For the purposes of LDV profiling, we have created an
        // indirection.
        LDV_RECORD_CREATE(p);

        p = prev;
    }
}
1006

1007
static void
Ben Gamari's avatar
Ben Gamari committed
1008
eval_thunk_selector (StgClosure **q, StgSelector * p, bool evac)
1009
                 // NB. for legacy reasons, p & q are swapped around :(
1010
{
1011
    uint32_t field;
1012
    StgInfoTable *info;
1013
    StgWord info_ptr;
1014
    StgClosure *selectee;
1015
1016
1017
    StgSelector *prev_thunk_selector;
    bdescr *bd;
    StgClosure *val;
1018

1019
1020
1021
    prev_thunk_selector = NULL;
    // this is a chain of THUNK_SELECTORs that we are going to update
    // to point to the value of the current THUNK_SELECTOR.  Each
1022
    // closure on the chain is a WHITEHOLE, and points to the next in the
1023
1024
1025
1026
1027
    // chain with payload[0].

selector_chain:

    bd = Bdescr((StgPtr)p);
1028
    if (HEAP_ALLOCED_GC(p)) {
1029
1030
1031
1032
1033
        // If the THUNK_SELECTOR is in to-space or in a generation that we
        // are not collecting, then bale out early.  We won't be able to
        // save any space in any case, and updating with an indirection is
        // trickier in a non-collected gen: we would have to update the
        // mutable list.
1034
        if (bd->flags & BF_EVACUATED) {
1035
            unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p);
1036
            *q = (StgClosure *)p;
1037
            // shortcut, behave as for:  if (evac) evacuate(q);
Simon Marlow's avatar
Simon Marlow committed
1038
            if (evac && bd->gen_no < gct->evac_gen_no) {
Ben Gamari's avatar
Ben Gamari committed
1039
                gct->failed_to_evac = true;
1040
1041
                TICK_GC_FAILED_PROMOTION();
            }
1042
            return;
1043
1044
1045
1046
1047
1048
1049
        }
        // we don't update THUNK_SELECTORS in the compacted
        // generation, because compaction does not remove the INDs
        // that result, this causes confusion later
        // (scavenge_mark_stack doesn't deal with IND).  BEWARE!  This
        // bit is very tricky to get right.  If you make changes
        // around here, test by compiling stage 3 with +RTS -c -RTS.
1050
        if (bd->flags & BF_MARKED) {
Ben Gamari's avatar
Ben Gamari committed
1051
            // must call evacuate() to mark this closure if evac==true
1052
1053
            *q = (StgClosure *)p;
            if (evac) evacuate(q);
1054
            unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p);
1055
            return;
1056
        }
1057
1058
    }

1059

1060
    // WHITEHOLE the selector thunk, since it is now under evaluation.
1061
1062
    // This is important to stop us going into an infinite loop if
    // this selector thunk eventually refers to itself.
1063
1064
1065
1066
#if defined(THREADED_RTS)
    // In threaded mode, we'll use WHITEHOLE to lock the selector
    // thunk while we evaluate it.
    {
Simon Marlow's avatar
Simon Marlow committed
1067
1068
1069
1070
1071
        do {
            info_ptr = xchg((StgPtr)&p->header.info, (W_)&stg_WHITEHOLE_info);
        } while (info_ptr == (W_)&stg_WHITEHOLE_info);

        // make sure someone else didn't get here first...