Enable new warning for fragile/incorrect CPP #if usage
[ghc.git] / rts / sm / CNF.c
1 /* -----------------------------------------------------------------------------
2 *
3 * (c) The GHC Team 1998-2014
4 *
5 * GC support for immutable non-GCed structures, also known as Compact
6 * Normal Forms (CNF for short). This provides the RTS support for
7 * the 'compact' package and the Data.Compact module.
8 *
9 * ---------------------------------------------------------------------------*/
10
11 #define _GNU_SOURCE
12
13 #include "PosixSource.h"
14 #include <string.h>
15 #include "Rts.h"
16 #include "RtsUtils.h"
17
18 #include "Capability.h"
19 #include "GC.h"
20 #include "Storage.h"
21 #include "CNF.h"
22 #include "Hash.h"
23 #include "HeapAlloc.h"
24 #include "BlockAlloc.h"
25 #include "Trace.h"
26 #include "sm/ShouldCompact.h"
27
28 #ifdef HAVE_UNISTD_H
29 #include <unistd.h>
30 #endif
31 #ifdef HAVE_LIMITS_H
32 #include <limits.h>
33 #endif
34
35 /*
36 Note [Compact Normal Forms]
37 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
38
39 A compact normal form (CNF) is a region of memory containing one or more
40 Haskell data structures. The goals are:
41
42 * The CNF lives or dies as a single unit as far as the GC is concerned. The
43 GC does not traverse the data inside the CNF.
44
45 * A CNF can be "serialized" (stored on disk or transmitted over a network).
46 To "deserialize", all we need to do is adjust the addresses of the pointers
47 within the CNF ("fixup"), Deserializing can only be done in the context of
48 the same Haskell binary that produced the CNF.
49
50 Structure
51 ~~~~~~~~~
52
53 * In Data.Compact.Internal we have
54 data Compact a = Compact Compact# a
55
56 * The Compact# primitive object is operated on by the primitives.
57
58 * A single CNF looks like this:
59
60 .---------, .-------------------------------. ,-------------
61 | Compact | ,--+-> StgCompactNFDataBlock | ,--->| StgCompac...
62 +---------+ `--+--- self | | | self
63 | .----+-. ,--+--- owner | | | wner
64 +---------+ | | | next ----------------------+---' | next -------->
65 | . | | | |-------------------------------+ +-------------
66 `----+----' `--+--+-> StgCompactNFData (Compact#) | | more data...
67 | | totalW | |
68 | | autoblockW | |
69 | | nursery | |
70 | | hash | |
71 | | last | |
72 | |-------------------------------| |
73 `------------+--> data ... | |
74 | | |
75 | | |
76 `-------------------------------' `-------------
77
78 * Each block in a CNF starts with a StgCompactNFDataBlock header
79
80 * The blocks in a CNF are chained through the next field
81
82 * Multiple CNFs are chained together using the bdescr->link and bdescr->u.prev
83 fields of the bdescr.
84
85 * The first block of a CNF (only) contains the StgCompactNFData (aka
86 Compact#), right after the StgCompactNFDataBlock header.
87
88 * The data inside a CNF block is ordinary closures
89
90 * During compaction (with sharing enabled) the hash field points to
91 a HashTable mapping heap addresses outside the compact to
92 addresses within it. If a GC strikes during compaction, this
93 HashTable must be scanned by the GC.
94
95 Invariants
96 ~~~~~~~~~~
97
98 (1) A CNF is self-contained. The data within it does not have any external
99 pointers. EXCEPT: pointers to static constructors that are guaranteed to
100 never refer (directly or indirectly) to CAFs are allowed, because the
101 garbage collector does not have to track or follow these.
102
103 (2) A CNF contains only immutable data: no THUNKS, FUNs, or mutable
104 objects. This helps maintain invariant (1).
105
106 Details
107 ~~~~~~~
108
109 Blocks are appended to the chain automatically as needed, or manually with a
110 compactResize() call, which also adjust the size of automatically appended
111 blocks.
112
113 Objects can be appended to the block currently marked to the nursery, or any
114 of the later blocks if the nursery block is too full to fit the entire
115 object. For each block in the chain (which can be multiple block allocator
116 blocks), we use the bdescr of its beginning to store how full it is.
117 After an object is appended, it is scavenged for any outgoing pointers,
118 and all pointed to objects are appended, recursively, in a manner similar
119 to copying GC (further discussion in the note [Appending to a Compact])
120
121 We also flag each bdescr in each block allocator block of a compact
122 (including those there were obtained as second or later from a single
123 allocGroup(n) call) with the BF_COMPACT. This allows the GC to quickly
124 realize that a given pointer is in a compact region, and trigger the
125 CNF path.
126
127 These two facts combined mean that in any compact block where some object
128 begins bdescrs must be valid. For this simplicity this is achieved by
129 restricting the maximum size of a compact block to 252 block allocator
130 blocks (so that the total with the bdescr is one megablock).
131
132 Compacts as a whole live in special list in each generation, where the
133 list is held through the bd->link field of the bdescr of the StgCompactNFData
134 closure (as for large objects). They live in a different list than large
135 objects because the operation to free them is different (all blocks in
136 a compact must be freed individually), and stats/sanity behavior are
137 slightly different. This is also the reason that compact allocates memory
138 using a special function instead of just calling allocate().
139
140 Compacts are also suitable for network or disk serialization, and to
141 that extent they support a pointer fixup operation, which adjusts pointers
142 from a previous layout of the chain in memory to the new allocation.
143 This works by constructing a temporary binary search table (in the C heap)
144 of the old block addresses (which are known from the block header), and
145 then searching for each pointer in the table, and adjusting it.
146 It relies on ABI compatibility and static linking (or no ASLR) because it
147 does not attempt to reconstruct info tables, and uses info tables to detect
148 pointers. In practice this means only the exact same binary should be
149 used.
150 */
151
152 typedef enum {
153 ALLOCATE_APPEND,
154 ALLOCATE_NEW,
155 ALLOCATE_IMPORT_NEW,
156 ALLOCATE_IMPORT_APPEND,
157 } AllocateOp;
158
159 static StgCompactNFDataBlock *
160 compactAllocateBlockInternal(Capability *cap,
161 StgWord aligned_size,
162 StgCompactNFDataBlock *first,
163 AllocateOp operation)
164 {
165 StgCompactNFDataBlock *self;
166 bdescr *block, *head;
167 uint32_t n_blocks;
168 generation *g;
169
170 n_blocks = aligned_size / BLOCK_SIZE;
171
172 // Attempting to allocate an object larger than maxHeapSize
173 // should definitely be disallowed. (bug #1791)
174 if ((RtsFlags.GcFlags.maxHeapSize > 0 &&
175 n_blocks >= RtsFlags.GcFlags.maxHeapSize) ||
176 n_blocks >= HS_INT32_MAX) // avoid overflow when
177 // calling allocGroup() below
178 {
179 reportHeapOverflow();
180 // reportHeapOverflow() doesn't exit (see #2592), but we aren't
181 // in a position to do a clean shutdown here: we
182 // either have to allocate the memory or exit now.
183 // Allocating the memory would be bad, because the user
184 // has requested that we not exceed maxHeapSize, so we
185 // just exit.
186 stg_exit(EXIT_HEAPOVERFLOW);
187 }
188
189 // It is imperative that first is the first block in the compact
190 // (or NULL if the compact does not exist yet)
191 // because the evacuate code does not update the generation of
192 // blocks other than the first (so we would get the statistics
193 // wrong and crash in Sanity)
194 if (first != NULL) {
195 block = Bdescr((P_)first);
196 g = block->gen;
197 } else {
198 g = g0;
199 }
200
201 ACQUIRE_SM_LOCK;
202 block = allocGroup(n_blocks);
203 switch (operation) {
204 case ALLOCATE_NEW:
205 ASSERT (first == NULL);
206 ASSERT (g == g0);
207 dbl_link_onto(block, &g0->compact_objects);
208 g->n_compact_blocks += block->blocks;
209 g->n_new_large_words += aligned_size / sizeof(StgWord);
210 break;
211
212 case ALLOCATE_IMPORT_NEW:
213 dbl_link_onto(block, &g0->compact_blocks_in_import);
214 /* fallthrough */
215 case ALLOCATE_IMPORT_APPEND:
216 ASSERT (first == NULL);
217 ASSERT (g == g0);
218 g->n_compact_blocks_in_import += block->blocks;
219 g->n_new_large_words += aligned_size / sizeof(StgWord);
220 break;
221
222 case ALLOCATE_APPEND:
223 g->n_compact_blocks += block->blocks;
224 if (g == g0)
225 g->n_new_large_words += aligned_size / sizeof(StgWord);
226 break;
227
228 default:
229 #ifdef DEBUG
230 ASSERT(!"code should not be reached");
231 #else
232 RTS_UNREACHABLE;
233 #endif
234 }
235 RELEASE_SM_LOCK;
236
237 cap->total_allocated += aligned_size / sizeof(StgWord);
238
239 self = (StgCompactNFDataBlock*) block->start;
240 self->self = self;
241 self->next = NULL;
242
243 head = block;
244 initBdescr(head, g, g);
245 head->flags = BF_COMPACT;
246 for (block = head + 1, n_blocks --; n_blocks > 0; block++, n_blocks--) {
247 block->link = head;
248 block->blocks = 0;
249 block->flags = BF_COMPACT;
250 }
251
252 return self;
253 }
254
255 static inline StgCompactNFDataBlock *
256 compactGetFirstBlock(StgCompactNFData *str)
257 {
258 return (StgCompactNFDataBlock*) ((W_)str - sizeof(StgCompactNFDataBlock));
259 }
260
261 static inline StgCompactNFData *
262 firstBlockGetCompact(StgCompactNFDataBlock *block)
263 {
264 return (StgCompactNFData*) ((W_)block + sizeof(StgCompactNFDataBlock));
265 }
266
267 void
268 compactFree(StgCompactNFData *str)
269 {
270 StgCompactNFDataBlock *block, *next;
271 bdescr *bd;
272
273 block = compactGetFirstBlock(str);
274
275 for ( ; block; block = next) {
276 next = block->next;
277 bd = Bdescr((StgPtr)block);
278 ASSERT((bd->flags & BF_EVACUATED) == 0);
279 freeGroup(bd);
280 }
281 }
282
283 void
284 compactMarkKnown(StgCompactNFData *str)
285 {
286 bdescr *bd;
287 StgCompactNFDataBlock *block;
288
289 block = compactGetFirstBlock(str);
290 for ( ; block; block = block->next) {
291 bd = Bdescr((StgPtr)block);
292 bd->flags |= BF_KNOWN;
293 }
294 }
295
296 StgWord
297 countCompactBlocks(bdescr *outer)
298 {
299 StgCompactNFDataBlock *block;
300 W_ count;
301
302 count = 0;
303 while (outer) {
304 bdescr *inner;
305
306 block = (StgCompactNFDataBlock*)(outer->start);
307 do {
308 inner = Bdescr((P_)block);
309 ASSERT (inner->flags & BF_COMPACT);
310
311 count += inner->blocks;
312 block = block->next;
313 } while(block);
314
315 outer = outer->link;
316 }
317
318 return count;
319 }
320
321 #ifdef DEBUG
322 // Like countCompactBlocks, but adjusts the size so each mblock is assumed to
323 // only contain BLOCKS_PER_MBLOCK blocks. Used in memInventory().
324 StgWord
325 countAllocdCompactBlocks(bdescr *outer)
326 {
327 StgCompactNFDataBlock *block;
328 W_ count;
329
330 count = 0;
331 while (outer) {
332 bdescr *inner;
333
334 block = (StgCompactNFDataBlock*)(outer->start);
335 do {
336 inner = Bdescr((P_)block);
337 ASSERT (inner->flags & BF_COMPACT);
338
339 count += inner->blocks;
340 // See BlockAlloc.c:countAllocdBlocks()
341 if (inner->blocks > BLOCKS_PER_MBLOCK) {
342 count -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
343 * (inner->blocks/(MBLOCK_SIZE/BLOCK_SIZE));
344 }
345 block = block->next;
346 } while(block);
347
348 outer = outer->link;
349 }
350
351 return count;
352 }
353 #endif
354
355 StgCompactNFData *
356 compactNew (Capability *cap, StgWord size)
357 {
358 StgWord aligned_size;
359 StgCompactNFDataBlock *block;
360 StgCompactNFData *self;
361 bdescr *bd;
362
363 aligned_size = BLOCK_ROUND_UP(size + sizeof(StgCompactNFData)
364 + sizeof(StgCompactNFDataBlock));
365
366 // Don't allow sizes larger than a megablock, because we can't use the
367 // memory after the first mblock for storing objects.
368 if (aligned_size >= BLOCK_SIZE * BLOCKS_PER_MBLOCK)
369 aligned_size = BLOCK_SIZE * BLOCKS_PER_MBLOCK;
370
371 block = compactAllocateBlockInternal(cap, aligned_size, NULL,
372 ALLOCATE_NEW);
373
374 self = firstBlockGetCompact(block);
375 SET_HDR((StgClosure*)self, &stg_COMPACT_NFDATA_CLEAN_info, CCS_SYSTEM);
376 self->autoBlockW = aligned_size / sizeof(StgWord);
377 self->nursery = block;
378 self->last = block;
379 self->hash = NULL;
380
381 block->owner = self;
382
383 bd = Bdescr((P_)block);
384 bd->free = (StgPtr)((W_)self + sizeof(StgCompactNFData));
385 self->hp = bd->free;
386 self->hpLim = bd->start + bd->blocks * BLOCK_SIZE_W;
387
388 self->totalW = bd->blocks * BLOCK_SIZE_W;
389
390 debugTrace(DEBUG_compact, "compactNew: size %" FMT_Word, size);
391
392 return self;
393 }
394
395 static StgCompactNFDataBlock *
396 compactAppendBlock (Capability *cap,
397 StgCompactNFData *str,
398 StgWord aligned_size)
399 {
400 StgCompactNFDataBlock *block;
401 bdescr *bd;
402
403 block = compactAllocateBlockInternal(cap, aligned_size,
404 compactGetFirstBlock(str),
405 ALLOCATE_APPEND);
406 block->owner = str;
407 block->next = NULL;
408
409 ASSERT (str->last->next == NULL);
410 str->last->next = block;
411 str->last = block;
412
413 bd = Bdescr((P_)block);
414 bd->free = (StgPtr)((W_)block + sizeof(StgCompactNFDataBlock));
415 ASSERT (bd->free == (StgPtr)block + sizeofW(StgCompactNFDataBlock));
416
417 str->totalW += bd->blocks * BLOCK_SIZE_W;
418
419 return block;
420 }
421
422 void
423 compactResize (Capability *cap, StgCompactNFData *str, StgWord new_size)
424 {
425 StgWord aligned_size;
426
427 aligned_size = BLOCK_ROUND_UP(new_size + sizeof(StgCompactNFDataBlock));
428
429 // Don't allow sizes larger than a megablock, because we can't use the
430 // memory after the first mblock for storing objects.
431 if (aligned_size >= BLOCK_SIZE * BLOCKS_PER_MBLOCK)
432 aligned_size = BLOCK_SIZE * BLOCKS_PER_MBLOCK;
433
434 str->autoBlockW = aligned_size / sizeof(StgWord);
435 compactAppendBlock(cap, str, aligned_size);
436 }
437
438 STATIC_INLINE bool
439 has_room_for (bdescr *bd, StgWord sizeW)
440 {
441 return (bd->free < bd->start + BLOCK_SIZE_W * BLOCKS_PER_MBLOCK
442 && bd->free + sizeW <= bd->start + BLOCK_SIZE_W * bd->blocks);
443 }
444
445 static bool
446 block_is_full (StgCompactNFDataBlock *block)
447 {
448 bdescr *bd;
449
450 // We consider a block full if we could not fit
451 // an entire closure with 7 payload items
452 // (this leaves a slop of 64 bytes at most, but
453 // it avoids leaving a block almost empty to fit
454 // a large byte array, while at the same time
455 // it avoids trying to allocate a large closure
456 // in a chain of almost empty blocks)
457
458 bd = Bdescr((StgPtr)block);
459 return (!has_room_for(bd,7));
460 }
461
462 void *
463 allocateForCompact (Capability *cap,
464 StgCompactNFData *str,
465 StgWord sizeW)
466 {
467 StgPtr to;
468 StgWord next_size;
469 StgCompactNFDataBlock *block;
470 bdescr *bd;
471
472 ASSERT(str->nursery != NULL);
473 ASSERT(str->hp > Bdescr((P_)str->nursery)->start);
474 ASSERT(str->hp <= Bdescr((P_)str->nursery)->start +
475 Bdescr((P_)str->nursery)->blocks * BLOCK_SIZE_W);
476
477 retry:
478 if (str->hp + sizeW < str->hpLim) {
479 to = str->hp;
480 str->hp += sizeW;
481 return to;
482 }
483
484 bd = Bdescr((P_)str->nursery);
485 bd->free = str->hp;
486
487 // We know it doesn't fit in the nursery
488 // if it is a large object, allocate a new block
489 if (sizeW > LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
490 next_size = BLOCK_ROUND_UP(sizeW*sizeof(W_) +
491 sizeof(StgCompactNFData));
492 block = compactAppendBlock(cap, str, next_size);
493 bd = Bdescr((P_)block);
494 to = bd->free;
495 bd->free += sizeW;
496 return to;
497 }
498
499 // move the nursery past full blocks
500 if (block_is_full (str->nursery)) {
501 do {
502 str->nursery = str->nursery->next;
503 } while (str->nursery && block_is_full(str->nursery));
504
505 if (str->nursery == NULL) {
506 str->nursery = compactAppendBlock(cap, str,
507 str->autoBlockW * sizeof(W_));
508 }
509 bd = Bdescr((P_)str->nursery);
510 str->hp = bd->free;
511 str->hpLim = bd->start + bd->blocks * BLOCK_SIZE_W;
512 goto retry;
513 }
514
515 // try subsequent blocks
516 for (block = str->nursery->next; block != NULL; block = block->next) {
517 bd = Bdescr((P_)block);
518 if (has_room_for(bd,sizeW)) {
519 to = bd->free;
520 bd->free += sizeW;
521 return to;
522 }
523 }
524
525 // If all else fails, allocate a new block of the right size.
526 next_size = stg_max(str->autoBlockW * sizeof(StgWord),
527 BLOCK_ROUND_UP(sizeW * sizeof(StgWord)
528 + sizeof(StgCompactNFDataBlock)));
529
530 block = compactAppendBlock(cap, str, next_size);
531 bd = Bdescr((P_)block);
532 to = bd->free;
533 bd->free += sizeW;
534 return to;
535 }
536
537
538 void
539 insertCompactHash (Capability *cap,
540 StgCompactNFData *str,
541 StgClosure *p, StgClosure *to)
542 {
543 insertHashTable(str->hash, (StgWord)p, (const void*)to);
544 if (str->header.info == &stg_COMPACT_NFDATA_CLEAN_info) {
545 str->header.info = &stg_COMPACT_NFDATA_DIRTY_info;
546 recordClosureMutated(cap, (StgClosure*)str);
547 }
548 }
549
550
551 StgWord
552 compactContains (StgCompactNFData *str, StgPtr what)
553 {
554 bdescr *bd;
555
556 // This check is the reason why this needs to be
557 // implemented in C instead of (possibly faster) Cmm
558 if (!HEAP_ALLOCED (what))
559 return 0;
560
561 // Note that we don't care about tags, they are eaten
562 // away by the Bdescr operation anyway
563 bd = Bdescr((P_)what);
564 return (bd->flags & BF_COMPACT) != 0 &&
565 (str == NULL || objectGetCompact((StgClosure*)what) == str);
566 }
567
568 StgCompactNFDataBlock *
569 compactAllocateBlock(Capability *cap,
570 StgWord size,
571 StgCompactNFDataBlock *previous)
572 {
573 StgWord aligned_size;
574 StgCompactNFDataBlock *block;
575 bdescr *bd;
576
577 aligned_size = BLOCK_ROUND_UP(size);
578
579 // We do not link the new object into the generation ever
580 // - we cannot let the GC know about this object until we're done
581 // importing it and we have fixed up all info tables and stuff
582 //
583 // but we do update n_compact_blocks, otherwise memInventory()
584 // in Sanity will think we have a memory leak, because it compares
585 // the blocks he knows about with the blocks obtained by the
586 // block allocator
587 // (if by chance a memory leak does happen due to a bug somewhere
588 // else, memInventory will also report that all compact blocks
589 // associated with this compact are leaked - but they are not really,
590 // we have a pointer to them and we're not losing track of it, it's
591 // just we can't use the GC until we're done with the import)
592 //
593 // (That btw means that the high level import code must be careful
594 // not to lose the pointer, so don't use the primops directly
595 // unless you know what you're doing!)
596
597 // Other trickery: we pass NULL as first, which means our blocks
598 // are always in generation 0
599 // This is correct because the GC has never seen the blocks so
600 // it had no chance of promoting them
601
602 block = compactAllocateBlockInternal(cap, aligned_size, NULL,
603 previous != NULL ? ALLOCATE_IMPORT_APPEND : ALLOCATE_IMPORT_NEW);
604 if (previous != NULL)
605 previous->next = block;
606
607 bd = Bdescr((P_)block);
608 bd->free = (P_)((W_)bd->start + size);
609
610 return block;
611 }
612
613 //
614 // shouldCompact(c,p): returns:
615 // SHOULDCOMPACT_IN_CNF if the object is in c
616 // SHOULDCOMPACT_STATIC if the object is static
617 // SHOULDCOMPACT_NOTIN_CNF if the object is dynamic and not in c
618 //
619 StgWord shouldCompact (StgCompactNFData *str, StgClosure *p)
620 {
621 bdescr *bd;
622
623 if (!HEAP_ALLOCED(p))
624 return SHOULDCOMPACT_STATIC; // we have to copy static closures too
625
626 bd = Bdescr((P_)p);
627 if (bd->flags & BF_PINNED) {
628 return SHOULDCOMPACT_PINNED;
629 }
630 if ((bd->flags & BF_COMPACT) && objectGetCompact(p) == str) {
631 return SHOULDCOMPACT_IN_CNF;
632 } else {
633 return SHOULDCOMPACT_NOTIN_CNF;
634 }
635 }
636
637 /* -----------------------------------------------------------------------------
638 Sanity-checking a compact
639 -------------------------------------------------------------------------- */
640
641 #ifdef DEBUG
642 STATIC_INLINE void
643 check_object_in_compact (StgCompactNFData *str, StgClosure *p)
644 {
645 bdescr *bd;
646
647 // Only certain static closures are allowed to be referenced from
648 // a compact, but let's be generous here and assume that all
649 // static closures are OK.
650 if (!HEAP_ALLOCED(p))
651 return;
652
653 bd = Bdescr((P_)p);
654 ASSERT((bd->flags & BF_COMPACT) != 0 && objectGetCompact(p) == str);
655 }
656
657 static void
658 verify_mut_arr_ptrs (StgCompactNFData *str,
659 StgMutArrPtrs *a)
660 {
661 StgPtr p, q;
662
663 p = (StgPtr)&a->payload[0];
664 q = (StgPtr)&a->payload[a->ptrs];
665 for (; p < q; p++) {
666 check_object_in_compact(str, UNTAG_CLOSURE(*(StgClosure**)p));
667 }
668
669 return;
670 }
671
672 static void
673 verify_consistency_block (StgCompactNFData *str, StgCompactNFDataBlock *block)
674 {
675 bdescr *bd;
676 StgPtr p;
677 const StgInfoTable *info;
678 StgClosure *q;
679
680 p = (P_)firstBlockGetCompact(block);
681 bd = Bdescr((P_)block);
682 while (p < bd->free) {
683 q = (StgClosure*)p;
684
685 ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
686
687 info = get_itbl(q);
688 switch (info->type) {
689 case CONSTR_1_0:
690 check_object_in_compact(str, UNTAG_CLOSURE(q->payload[0]));
691 case CONSTR_0_1:
692 p += sizeofW(StgClosure) + 1;
693 break;
694
695 case CONSTR_2_0:
696 check_object_in_compact(str, UNTAG_CLOSURE(q->payload[1]));
697 case CONSTR_1_1:
698 check_object_in_compact(str, UNTAG_CLOSURE(q->payload[0]));
699 case CONSTR_0_2:
700 p += sizeofW(StgClosure) + 2;
701 break;
702
703 case CONSTR:
704 case PRIM:
705 case CONSTR_NOCAF:
706 {
707 uint32_t i;
708
709 for (i = 0; i < info->layout.payload.ptrs; i++) {
710 check_object_in_compact(str, UNTAG_CLOSURE(q->payload[i]));
711 }
712 p += sizeofW(StgClosure) + info->layout.payload.ptrs +
713 info->layout.payload.nptrs;
714 break;
715 }
716
717 case ARR_WORDS:
718 p += arr_words_sizeW((StgArrBytes*)p);
719 break;
720
721 case MUT_ARR_PTRS_FROZEN:
722 case MUT_ARR_PTRS_FROZEN0:
723 verify_mut_arr_ptrs(str, (StgMutArrPtrs*)p);
724 p += mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
725 break;
726
727 case SMALL_MUT_ARR_PTRS_FROZEN:
728 case SMALL_MUT_ARR_PTRS_FROZEN0:
729 {
730 uint32_t i;
731 StgSmallMutArrPtrs *arr = (StgSmallMutArrPtrs*)p;
732
733 for (i = 0; i < arr->ptrs; i++)
734 check_object_in_compact(str, UNTAG_CLOSURE(arr->payload[i]));
735
736 p += sizeofW(StgSmallMutArrPtrs) + arr->ptrs;
737 break;
738 }
739
740 case COMPACT_NFDATA:
741 p += sizeofW(StgCompactNFData);
742 break;
743
744 default:
745 barf("verify_consistency_block");
746 }
747 }
748
749 return;
750 }
751
752 static void
753 verify_consistency_loop (StgCompactNFData *str)
754 {
755 StgCompactNFDataBlock *block;
756
757 block = compactGetFirstBlock(str);
758 do {
759 verify_consistency_block(str, block);
760 block = block->next;
761 } while (block && block->owner);
762 }
763
764 void verifyCompact (StgCompactNFData *str USED_IF_DEBUG)
765 {
766 IF_DEBUG(sanity, verify_consistency_loop(str));
767 }
768 #endif // DEBUG
769
770 /* -----------------------------------------------------------------------------
771 Fixing up pointers
772 -------------------------------------------------------------------------- */
773
774 STATIC_INLINE bool
775 any_needs_fixup(StgCompactNFDataBlock *block)
776 {
777 // ->next pointers are always valid, even if some blocks were
778 // not allocated where we want them, because compactAllocateAt()
779 // will take care to adjust them
780
781 do {
782 if (block->self != block)
783 return true;
784 block = block->next;
785 } while (block && block->owner);
786
787 return false;
788 }
789
790 #ifdef DEBUG
791 static void
792 spew_failing_pointer(StgWord *fixup_table, uint32_t count, StgWord address)
793 {
794 uint32_t i;
795 StgWord key, value;
796 StgCompactNFDataBlock *block;
797 bdescr *bd;
798 StgWord size;
799
800 debugBelch("Failed to adjust 0x%" FMT_HexWord ". Block dump follows...\n",
801 address);
802
803 for (i = 0; i < count; i++) {
804 key = fixup_table [2 * i];
805 value = fixup_table [2 * i + 1];
806
807 block = (StgCompactNFDataBlock*)value;
808 bd = Bdescr((P_)block);
809 size = (W_)bd->free - (W_)bd->start;
810
811 debugBelch("%" FMT_Word32 ": was 0x%" FMT_HexWord "-0x%" FMT_HexWord
812 ", now 0x%" FMT_HexWord "-0x%" FMT_HexWord "\n", i, key,
813 key+size, value, value+size);
814 }
815 }
816 #endif
817
818 STATIC_INLINE StgCompactNFDataBlock *
819 find_pointer(StgWord *fixup_table, uint32_t count, StgClosure *q)
820 {
821 StgWord address = (W_)q;
822 uint32_t a, b, c;
823 StgWord key, value;
824 bdescr *bd;
825
826 a = 0;
827 b = count;
828 while (a < b-1) {
829 c = (a+b)/2;
830
831 key = fixup_table[c * 2];
832 value = fixup_table[c * 2 + 1];
833
834 if (key > address)
835 b = c;
836 else
837 a = c;
838 }
839
840 // three cases here: 0, 1 or 2 blocks to check
841 for ( ; a < b; a++) {
842 key = fixup_table[a * 2];
843 value = fixup_table[a * 2 + 1];
844
845 if (key > address)
846 goto fail;
847
848 bd = Bdescr((P_)value);
849
850 if (key + bd->blocks * BLOCK_SIZE <= address)
851 goto fail;
852
853 return (StgCompactNFDataBlock*)value;
854 }
855
856 fail:
857 // We should never get here
858
859 #ifdef DEBUG
860 spew_failing_pointer(fixup_table, count, address);
861 #endif
862 return NULL;
863 }
864
865 static bool
866 fixup_one_pointer(StgWord *fixup_table, uint32_t count, StgClosure **p)
867 {
868 StgWord tag;
869 StgClosure *q;
870 StgCompactNFDataBlock *block;
871
872
873 q = *p;
874 tag = GET_CLOSURE_TAG(q);
875 q = UNTAG_CLOSURE(q);
876
877 // We can encounter a pointer outside the compact if it points to
878 // a static constructor that does not (directly or indirectly)
879 // reach any CAFs. (see Note [Compact Normal Forms])
880 if (!HEAP_ALLOCED(q))
881 return true;
882
883 block = find_pointer(fixup_table, count, q);
884 if (block == NULL)
885 return false;
886 if (block == block->self)
887 return true;
888
889 q = (StgClosure*)((W_)q - (W_)block->self + (W_)block);
890 *p = TAG_CLOSURE(tag, q);
891
892 return true;
893 }
894
895 static bool
896 fixup_mut_arr_ptrs (StgWord *fixup_table,
897 uint32_t count,
898 StgMutArrPtrs *a)
899 {
900 StgPtr p, q;
901
902 p = (StgPtr)&a->payload[0];
903 q = (StgPtr)&a->payload[a->ptrs];
904 for (; p < q; p++) {
905 if (!fixup_one_pointer(fixup_table, count, (StgClosure**)p))
906 return false;
907 }
908
909 return true;
910 }
911
912 static bool
913 fixup_block(StgCompactNFDataBlock *block, StgWord *fixup_table, uint32_t count)
914 {
915 const StgInfoTable *info;
916 bdescr *bd;
917 StgPtr p;
918
919 bd = Bdescr((P_)block);
920 p = bd->start + sizeofW(StgCompactNFDataBlock);
921 while (p < bd->free) {
922 ASSERT (LOOKS_LIKE_CLOSURE_PTR(p));
923 info = get_itbl((StgClosure*)p);
924
925 switch (info->type) {
926 case CONSTR_1_0:
927 if (!fixup_one_pointer(fixup_table, count,
928 &((StgClosure*)p)->payload[0]))
929 return false;
930 case CONSTR_0_1:
931 p += sizeofW(StgClosure) + 1;
932 break;
933
934 case CONSTR_2_0:
935 if (!fixup_one_pointer(fixup_table, count,
936 &((StgClosure*)p)->payload[1]))
937 return false;
938 case CONSTR_1_1:
939 if (!fixup_one_pointer(fixup_table, count,
940 &((StgClosure*)p)->payload[0]))
941 return false;
942 case CONSTR_0_2:
943 p += sizeofW(StgClosure) + 2;
944 break;
945
946 case CONSTR:
947 case PRIM:
948 case CONSTR_NOCAF:
949 {
950 StgPtr end;
951
952 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
953 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
954 if (!fixup_one_pointer(fixup_table, count, (StgClosure **)p))
955 return false;
956 }
957 p += info->layout.payload.nptrs;
958 break;
959 }
960
961 case ARR_WORDS:
962 p += arr_words_sizeW((StgArrBytes*)p);
963 break;
964
965 case MUT_ARR_PTRS_FROZEN:
966 case MUT_ARR_PTRS_FROZEN0:
967 fixup_mut_arr_ptrs(fixup_table, count, (StgMutArrPtrs*)p);
968 p += mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
969 break;
970
971 case SMALL_MUT_ARR_PTRS_FROZEN:
972 case SMALL_MUT_ARR_PTRS_FROZEN0:
973 {
974 uint32_t i;
975 StgSmallMutArrPtrs *arr = (StgSmallMutArrPtrs*)p;
976
977 for (i = 0; i < arr->ptrs; i++) {
978 if (!fixup_one_pointer(fixup_table, count,
979 &arr->payload[i]))
980 return false;
981 }
982
983 p += sizeofW(StgSmallMutArrPtrs) + arr->ptrs;
984 break;
985 }
986
987 case COMPACT_NFDATA:
988 if (p == (bd->start + sizeofW(StgCompactNFDataBlock))) {
989 // Ignore the COMPACT_NFDATA header
990 // (it will be fixed up later)
991 p += sizeofW(StgCompactNFData);
992 break;
993 }
994
995 // fall through
996
997 default:
998 debugBelch("Invalid non-NFData closure (type %d) in Compact\n",
999 info->type);
1000 return false;
1001 }
1002 }
1003
1004 return true;
1005 }
1006
1007 static int
1008 cmp_fixup_table_item (const void *e1, const void *e2)
1009 {
1010 const StgWord *w1 = e1;
1011 const StgWord *w2 = e2;
1012
1013 return *w1 - *w2;
1014 }
1015
1016 static StgWord *
1017 build_fixup_table (StgCompactNFDataBlock *block, uint32_t *pcount)
1018 {
1019 uint32_t count;
1020 StgCompactNFDataBlock *tmp;
1021 StgWord *table;
1022
1023 count = 0;
1024 tmp = block;
1025 do {
1026 count++;
1027 tmp = tmp->next;
1028 } while(tmp && tmp->owner);
1029
1030 table = stgMallocBytes(sizeof(StgWord) * 2 * count, "build_fixup_table");
1031
1032 count = 0;
1033 do {
1034 table[count * 2] = (W_)block->self;
1035 table[count * 2 + 1] = (W_)block;
1036 count++;
1037 block = block->next;
1038 } while(block && block->owner);
1039
1040 qsort(table, count, sizeof(StgWord) * 2, cmp_fixup_table_item);
1041
1042 *pcount = count;
1043 return table;
1044 }
1045
1046 static bool
1047 fixup_loop(StgCompactNFDataBlock *block, StgClosure **proot)
1048 {
1049 StgWord *table;
1050 bool ok;
1051 uint32_t count;
1052
1053 table = build_fixup_table (block, &count);
1054
1055 do {
1056 if (!fixup_block(block, table, count)) {
1057 ok = false;
1058 goto out;
1059 }
1060
1061 block = block->next;
1062 } while(block && block->owner);
1063
1064 ok = fixup_one_pointer(table, count, proot);
1065
1066 out:
1067 stgFree(table);
1068 return ok;
1069 }
1070
1071 static void
1072 fixup_early(StgCompactNFData *str, StgCompactNFDataBlock *block)
1073 {
1074 StgCompactNFDataBlock *last;
1075
1076 do {
1077 last = block;
1078 block = block->next;
1079 } while(block);
1080
1081 str->last = last;
1082 }
1083
1084 static void
1085 fixup_late(StgCompactNFData *str, StgCompactNFDataBlock *block)
1086 {
1087 StgCompactNFDataBlock *nursery;
1088 bdescr *bd;
1089 StgWord totalW;
1090
1091 nursery = block;
1092 totalW = 0;
1093 do {
1094 block->self = block;
1095
1096 bd = Bdescr((P_)block);
1097 totalW += bd->blocks * BLOCK_SIZE_W;
1098
1099 if (block->owner != NULL) {
1100 if (bd->free != bd->start)
1101 nursery = block;
1102 block->owner = str;
1103 }
1104
1105 block = block->next;
1106 } while(block);
1107
1108 str->nursery = nursery;
1109 bd = Bdescr((P_)nursery);
1110 str->hp = bd->free;
1111 str->hpLim = bd->start + bd->blocks * BLOCK_SIZE_W;
1112
1113 str->totalW = totalW;
1114 }
1115
1116 static StgClosure *
1117 maybe_fixup_internal_pointers (StgCompactNFDataBlock *block,
1118 StgClosure *root)
1119 {
1120 bool ok;
1121 StgClosure **proot;
1122
1123 // Check for fast path
1124 if (!any_needs_fixup(block))
1125 return root;
1126
1127 debugBelch("Compact imported at the wrong address, will fix up"
1128 " internal pointers\n");
1129
1130 // I am PROOT!
1131 proot = &root;
1132
1133 ok = fixup_loop(block, proot);
1134 if (!ok)
1135 *proot = NULL;
1136
1137 return *proot;
1138 }
1139
1140 StgPtr
1141 compactFixupPointers(StgCompactNFData *str,
1142 StgClosure *root)
1143 {
1144 StgCompactNFDataBlock *block;
1145 bdescr *bd;
1146 StgWord total_blocks;
1147
1148 block = compactGetFirstBlock(str);
1149
1150 fixup_early(str, block);
1151
1152 root = maybe_fixup_internal_pointers(block, root);
1153
1154 // Do the late fixup even if we did not fixup all
1155 // internal pointers, we need that for GC and Sanity
1156 fixup_late(str, block);
1157
1158 // Now we're ready to let the GC, Sanity, the profiler
1159 // etc. know about this object
1160 bd = Bdescr((P_)block);
1161
1162 total_blocks = str->totalW / BLOCK_SIZE_W;
1163
1164 ACQUIRE_SM_LOCK;
1165 ASSERT (bd->gen == g0);
1166 ASSERT (g0->n_compact_blocks_in_import >= total_blocks);
1167 g0->n_compact_blocks_in_import -= total_blocks;
1168 g0->n_compact_blocks += total_blocks;
1169 dbl_link_remove(bd, &g0->compact_blocks_in_import);
1170 dbl_link_onto(bd, &g0->compact_objects);
1171 RELEASE_SM_LOCK;
1172
1173 #ifdef DEBUG
1174 if (root)
1175 verify_consistency_loop(str);
1176 #endif
1177
1178 return (StgPtr)root;
1179 }