Remove CONSTR_STATIC
[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
26 #ifdef HAVE_UNISTD_H
27 #include <unistd.h>
28 #endif
29 #ifdef HAVE_LIMITS_H
30 #include <limits.h>
31 #endif
32
33 /**
34 * Note [Compact Normal Forms]
35 *
36 * A Compact Normal Form, is at its essence a chain of memory blocks (multiple
37 * of block allocator blocks) containing other closures inside.
38 *
39 * Each block starts with a header, of type StgCompactNFDataBlock, that points
40 * to the first and to the next block in the chain. Right after the header
41 * in the first block we have a closure of type StgCompactNFData, which holds
42 * compact-wide metadata. This closure is the Compact# that Cmm and Haskell
43 * see, and it's mostly a regular Haskell closure.
44 *
45 * Blocks are appended to the chain automatically as needed, or manually with a
46 * compactResize() call, which also adjust the size of automatically appended
47 * blocks.
48 *
49 * Objects can be appended to the block currently marked to the nursery, or any
50 * of the later blocks if the nursery block is too full to fit the entire
51 * object. For each block in the chain (which can be multiple block allocator
52 * blocks), we use the bdescr of its beginning to store how full it is.
53 * After an object is appended, it is scavenged for any outgoing pointers,
54 * and all pointed to objects are appended, recursively, in a manner similar
55 * to copying GC (further discussion in the note [Appending to a Compact])
56 *
57 * We also flag each bdescr in each block allocator block of a compact
58 * (including those there were obtained as second or later from a single
59 * allocGroup(n) call) with the BF_COMPACT. This allows the GC to quickly
60 * realize that a given pointer is in a compact region, and trigger the
61 * CNF path.
62 *
63 * These two facts combined mean that in any compact block where some object
64 * begins bdescrs must be valid. For this simplicity this is achieved by
65 * restricting the maximum size of a compact block to 252 block allocator
66 * blocks (so that the total with the bdescr is one megablock).
67 *
68 * Compacts as a whole live in special list in each generation, where the
69 * list is held through the bd->link field of the bdescr of the StgCompactNFData
70 * closure (as for large objects). They live in a different list than large
71 * objects because the operation to free them is different (all blocks in
72 * a compact must be freed individually), and stats/sanity behavior are
73 * slightly different. This is also the reason that compact allocates memory
74 * using a special function instead of just calling allocate().
75 *
76 * Compacts are also suitable for network or disk serialization, and to
77 * that extent they support a pointer fixup operation, which adjusts pointers
78 * from a previous layout of the chain in memory to the new allocation.
79 * This works by constructing a temporary binary search table (in the C heap)
80 * of the old block addresses (which are known from the block header), and
81 * then searching for each pointer in the table, and adjusting it.
82 * It relies on ABI compatibility and static linking (or no ASLR) because it
83 * does not attempt to reconstruct info tables, and uses info tables to detect
84 * pointers. In practice this means only the exact same binary should be
85 * used.
86 */
87
88 typedef enum {
89 ALLOCATE_APPEND,
90 ALLOCATE_NEW,
91 ALLOCATE_IMPORT_NEW,
92 ALLOCATE_IMPORT_APPEND,
93 } AllocateOp;
94
95 static StgCompactNFDataBlock *
96 compactAllocateBlockInternal(Capability *cap,
97 StgWord aligned_size,
98 StgCompactNFDataBlock *first,
99 AllocateOp operation)
100 {
101 StgCompactNFDataBlock *self;
102 bdescr *block, *head;
103 uint32_t n_blocks;
104 generation *g;
105
106 n_blocks = aligned_size / BLOCK_SIZE;
107
108 // Attempting to allocate an object larger than maxHeapSize
109 // should definitely be disallowed. (bug #1791)
110 if ((RtsFlags.GcFlags.maxHeapSize > 0 &&
111 n_blocks >= RtsFlags.GcFlags.maxHeapSize) ||
112 n_blocks >= HS_INT32_MAX) // avoid overflow when
113 // calling allocGroup() below
114 {
115 heapOverflow();
116 // heapOverflow() doesn't exit (see #2592), but we aren't
117 // in a position to do a clean shutdown here: we
118 // either have to allocate the memory or exit now.
119 // Allocating the memory would be bad, because the user
120 // has requested that we not exceed maxHeapSize, so we
121 // just exit.
122 stg_exit(EXIT_HEAPOVERFLOW);
123 }
124
125 // It is imperative that first is the first block in the compact
126 // (or NULL if the compact does not exist yet)
127 // because the evacuate code does not update the generation of
128 // blocks other than the first (so we would get the statistics
129 // wrong and crash in Sanity)
130 if (first != NULL) {
131 block = Bdescr((P_)first);
132 g = block->gen;
133 } else {
134 g = g0;
135 }
136
137 ACQUIRE_SM_LOCK;
138 block = allocGroup(n_blocks);
139 switch (operation) {
140 case ALLOCATE_NEW:
141 ASSERT (first == NULL);
142 ASSERT (g == g0);
143 dbl_link_onto(block, &g0->compact_objects);
144 g->n_compact_blocks += block->blocks;
145 g->n_new_large_words += aligned_size / sizeof(StgWord);
146 break;
147
148 case ALLOCATE_IMPORT_NEW:
149 dbl_link_onto(block, &g0->compact_blocks_in_import);
150 /* fallthrough */
151 case ALLOCATE_IMPORT_APPEND:
152 ASSERT (first == NULL);
153 ASSERT (g == g0);
154 g->n_compact_blocks_in_import += block->blocks;
155 g->n_new_large_words += aligned_size / sizeof(StgWord);
156 break;
157
158 case ALLOCATE_APPEND:
159 g->n_compact_blocks += block->blocks;
160 if (g == g0)
161 g->n_new_large_words += aligned_size / sizeof(StgWord);
162 break;
163
164 default:
165 #ifdef DEBUG
166 ASSERT(!"code should not be reached");
167 #else
168 RTS_UNREACHABLE;
169 #endif
170 }
171 RELEASE_SM_LOCK;
172
173 cap->total_allocated += aligned_size / sizeof(StgWord);
174
175 self = (StgCompactNFDataBlock*) block->start;
176 self->self = self;
177 self->next = NULL;
178
179 head = block;
180 initBdescr(head, g, g);
181 head->flags = BF_COMPACT;
182 for (block = head + 1, n_blocks --; n_blocks > 0; block++, n_blocks--) {
183 block->link = head;
184 block->blocks = 0;
185 block->flags = BF_COMPACT;
186 }
187
188 return self;
189 }
190
191 static inline StgCompactNFDataBlock *
192 compactGetFirstBlock(StgCompactNFData *str)
193 {
194 return (StgCompactNFDataBlock*) ((W_)str - sizeof(StgCompactNFDataBlock));
195 }
196
197 static inline StgCompactNFData *
198 firstBlockGetCompact(StgCompactNFDataBlock *block)
199 {
200 return (StgCompactNFData*) ((W_)block + sizeof(StgCompactNFDataBlock));
201 }
202
203 static void
204 freeBlockChain(StgCompactNFDataBlock *block)
205 {
206 StgCompactNFDataBlock *next;
207 bdescr *bd;
208
209 for ( ; block; block = next) {
210 next = block->next;
211 bd = Bdescr((StgPtr)block);
212 ASSERT((bd->flags & BF_EVACUATED) == 0);
213 freeGroup(bd);
214 }
215 }
216
217 void
218 compactFree(StgCompactNFData *str)
219 {
220 StgCompactNFDataBlock *block;
221
222 block = compactGetFirstBlock(str);
223 freeBlockChain(block);
224 }
225
226 void
227 compactMarkKnown(StgCompactNFData *str)
228 {
229 bdescr *bd;
230 StgCompactNFDataBlock *block;
231
232 block = compactGetFirstBlock(str);
233 for ( ; block; block = block->next) {
234 bd = Bdescr((StgPtr)block);
235 bd->flags |= BF_KNOWN;
236 }
237 }
238
239 StgWord
240 countCompactBlocks(bdescr *outer)
241 {
242 StgCompactNFDataBlock *block;
243 W_ count;
244
245 count = 0;
246 while (outer) {
247 bdescr *inner;
248
249 block = (StgCompactNFDataBlock*)(outer->start);
250 do {
251 inner = Bdescr((P_)block);
252 ASSERT (inner->flags & BF_COMPACT);
253
254 count += inner->blocks;
255 block = block->next;
256 } while(block);
257
258 outer = outer->link;
259 }
260
261 return count;
262 }
263
264 StgCompactNFData *
265 compactNew (Capability *cap, StgWord size)
266 {
267 StgWord aligned_size;
268 StgCompactNFDataBlock *block;
269 StgCompactNFData *self;
270 bdescr *bd;
271
272 aligned_size = BLOCK_ROUND_UP(size + sizeof(StgCompactNFDataBlock)
273 + sizeof(StgCompactNFDataBlock));
274 if (aligned_size >= BLOCK_SIZE * BLOCKS_PER_MBLOCK)
275 aligned_size = BLOCK_SIZE * BLOCKS_PER_MBLOCK;
276
277 block = compactAllocateBlockInternal(cap, aligned_size, NULL,
278 ALLOCATE_NEW);
279
280 self = firstBlockGetCompact(block);
281 SET_INFO((StgClosure*)self, &stg_COMPACT_NFDATA_info);
282 self->totalDataW = aligned_size / sizeof(StgWord);
283 self->autoBlockW = aligned_size / sizeof(StgWord);
284 self->nursery = block;
285 self->last = block;
286
287 block->owner = self;
288
289 bd = Bdescr((P_)block);
290 bd->free = (StgPtr)((W_)self + sizeof(StgCompactNFData));
291 ASSERT (bd->free == (StgPtr)self + sizeofW(StgCompactNFData));
292
293 self->totalW = bd->blocks * BLOCK_SIZE_W;
294
295 return self;
296 }
297
298 static StgCompactNFDataBlock *
299 compactAppendBlock (Capability *cap,
300 StgCompactNFData *str,
301 StgWord aligned_size)
302 {
303 StgCompactNFDataBlock *block;
304 bdescr *bd;
305
306 block = compactAllocateBlockInternal(cap, aligned_size,
307 compactGetFirstBlock(str),
308 ALLOCATE_APPEND);
309 block->owner = str;
310 block->next = NULL;
311
312 ASSERT (str->last->next == NULL);
313 str->last->next = block;
314 str->last = block;
315 if (str->nursery == NULL)
316 str->nursery = block;
317 str->totalDataW += aligned_size / sizeof(StgWord);
318
319 bd = Bdescr((P_)block);
320 bd->free = (StgPtr)((W_)block + sizeof(StgCompactNFDataBlock));
321 ASSERT (bd->free == (StgPtr)block + sizeofW(StgCompactNFDataBlock));
322
323 str->totalW += bd->blocks * BLOCK_SIZE_W;
324
325 return block;
326 }
327
328 void
329 compactResize (Capability *cap, StgCompactNFData *str, StgWord new_size)
330 {
331 StgWord aligned_size;
332
333 aligned_size = BLOCK_ROUND_UP(new_size + sizeof(StgCompactNFDataBlock));
334 if (aligned_size >= BLOCK_SIZE * BLOCKS_PER_MBLOCK)
335 aligned_size = BLOCK_SIZE * BLOCKS_PER_MBLOCK;
336
337 str->autoBlockW = aligned_size / sizeof(StgWord);
338
339 compactAppendBlock(cap, str, aligned_size);
340 }
341
342 /* Note [Appending to a Compact]
343
344 This is a simple reimplementation of the copying GC.
345 One could be tempted to reuse the actual GC code here, but he
346 would quickly find out that it would bring all the generational
347 GC complexity for no need at all.
348
349 Plus, we don't need to scavenge/evacuate all kinds of weird
350 objects here, just constructors and primitives. Thunks are
351 expected to be evaluated before appending by the API layer
352 (in Haskell, above the primop which is implemented here).
353 Also, we have a different policy for large objects: instead
354 of relinking to the new large object list, we fully copy
355 them inside the compact and scavenge them normally.
356
357 Note that if we allowed thunks and lazy evaluation the compact
358 would be a mutable object, which would create all sorts of
359 GC problems (besides, evaluating a thunk could exaust the
360 compact space or yield an invalid object, and we would have
361 no way to signal that to the user)
362
363 Just like the real evacuate/scavenge pairs, we need to handle
364 object loops. We would want to use the same strategy of rewriting objects
365 with forwarding pointer, but in a real GC, at the end the
366 blocks from the old space are dropped (dropping all forwarding
367 pointers at the same time), which we can't do here as we don't
368 know all pointers to the objects being evacuated. Also, in parallel
369 we don't know which other threads are evaluating the thunks
370 that we just corrupted at the same time.
371
372 So instead we use a hash table of "visited" objects, and add
373 the pointer as we copy it. To reduce the overhead, we also offer
374 a version of the API that does not preserve sharing (TODO).
375
376 You might be tempted to replace the objects with StdInd to
377 the object in the compact, but you would be wrong: the haskell
378 code assumes that objects in the heap only become more evaluated
379 (thunks to blackholes to inds to actual objects), and in
380 particular it assumes that if a pointer is tagged the object
381 is directly referenced and the values can be read directly,
382 without entering the closure.
383
384 FIXME: any better idea than the hash table?
385 */
386
387 static void
388 unroll_memcpy(StgPtr to, StgPtr from, StgWord size)
389 {
390 for (; size > 0; size--)
391 *(to++) = *(from++);
392 }
393
394 static rtsBool
395 allocate_in_compact (StgCompactNFDataBlock *block, StgWord sizeW, StgPtr *at)
396 {
397 bdescr *bd;
398 StgPtr top;
399 StgPtr free;
400
401 bd = Bdescr((StgPtr)block);
402 top = bd->start + BLOCK_SIZE_W * bd->blocks;
403 if (bd->free + sizeW > top)
404 return rtsFalse;
405
406 free = bd->free;
407 bd->free += sizeW;
408 *at = free;
409
410 return rtsTrue;
411 }
412
413 static rtsBool
414 block_is_full (StgCompactNFDataBlock *block)
415 {
416 bdescr *bd;
417 StgPtr top;
418 StgWord sizeW;
419
420 bd = Bdescr((StgPtr)block);
421 top = bd->start + BLOCK_SIZE_W * bd->blocks;
422
423 // We consider a block full if we could not fit
424 // an entire closure with 7 payload items
425 // (this leaves a slop of 64 bytes at most, but
426 // it avoids leaving a block almost empty to fit
427 // a large byte array, while at the same time
428 // it avoids trying to allocate a large closure
429 // in a chain of almost empty blocks)
430 sizeW = sizeofW(StgHeader) + 7;
431 return (bd->free + sizeW > top);
432 }
433
434 static rtsBool
435 allocate_loop (Capability *cap,
436 StgCompactNFData *str,
437 StgWord sizeW,
438 StgPtr *at)
439 {
440 StgCompactNFDataBlock *block;
441 StgWord next_size;
442
443 // try the nursery first
444 retry:
445 if (str->nursery != NULL) {
446 if (allocate_in_compact(str->nursery, sizeW, at))
447 return rtsTrue;
448
449 if (block_is_full (str->nursery)) {
450 str->nursery = str->nursery->next;
451 goto retry;
452 }
453
454 // try subsequent blocks
455 block = str->nursery->next;
456 while (block != NULL) {
457 if (allocate_in_compact(block, sizeW, at))
458 return rtsTrue;
459
460 block = block->next;
461 }
462 }
463
464 next_size = stg_max(str->autoBlockW * sizeof(StgWord),
465 BLOCK_ROUND_UP(sizeW * sizeof(StgWord)));
466 if (next_size >= BLOCKS_PER_MBLOCK * BLOCK_SIZE)
467 next_size = BLOCKS_PER_MBLOCK * BLOCK_SIZE;
468 if (next_size < sizeW * sizeof(StgWord) + sizeof(StgCompactNFDataBlock))
469 return rtsFalse;
470
471 block = compactAppendBlock(cap, str, next_size);
472 ASSERT (str->nursery != NULL);
473 return allocate_in_compact(block, sizeW, at);
474 }
475
476 static void
477 copy_tag (Capability *cap,
478 StgCompactNFData *str,
479 HashTable *hash,
480 StgClosure **p,
481 StgClosure *from,
482 StgWord tag)
483 {
484 StgPtr to;
485 StgWord sizeW;
486
487 sizeW = closure_sizeW(from);
488
489 if (!allocate_loop(cap, str, sizeW, &to)) {
490 barf("Failed to copy object in compact, object too large\n");
491 return;
492 }
493
494 // unroll memcpy for small sizes because we can
495 // benefit of known alignment
496 // (32 extracted from my magic hat)
497 if (sizeW < 32)
498 unroll_memcpy(to, (StgPtr)from, sizeW);
499 else
500 memcpy(to, from, sizeW * sizeof(StgWord));
501
502 if (hash != NULL)
503 insertHashTable(hash, (StgWord)from, to);
504
505 *p = TAG_CLOSURE(tag, (StgClosure*)to);
506 }
507
508 STATIC_INLINE rtsBool
509 object_in_compact (StgCompactNFData *str, StgClosure *p)
510 {
511 bdescr *bd;
512
513 if (!HEAP_ALLOCED(p))
514 return rtsFalse;
515
516 bd = Bdescr((P_)p);
517 return (bd->flags & BF_COMPACT) != 0 &&
518 objectGetCompact(p) == str;
519 }
520
521 static void
522 simple_evacuate (Capability *cap,
523 StgCompactNFData *str,
524 HashTable *hash,
525 StgClosure **p)
526 {
527 StgWord tag;
528 StgClosure *from;
529 void *already;
530
531 from = *p;
532 tag = GET_CLOSURE_TAG(from);
533 from = UNTAG_CLOSURE(from);
534
535 // If the object referenced is already in this compact
536 // (for example by reappending an object that was obtained
537 // by compactGetRoot) then do nothing
538 if (object_in_compact(str, from))
539 return;
540
541 switch (get_itbl(from)->type) {
542 case BLACKHOLE:
543 // If tag == 0, the indirectee is the TSO that claimed the tag
544 //
545 // Not useful and not NFData
546 from = ((StgInd*)from)->indirectee;
547 if (GET_CLOSURE_TAG(from) == 0) {
548 debugBelch("Claimed but not updated BLACKHOLE in Compact,"
549 " not normal form");
550 return;
551 }
552
553 *p = from;
554 return simple_evacuate(cap, str, hash, p);
555
556 case IND:
557 case IND_STATIC:
558 // follow chains of indirections, don't evacuate them
559 from = ((StgInd*)from)->indirectee;
560 *p = from;
561 // Evac.c uses a goto, but let's rely on a smart compiler
562 // and get readable code instead
563 return simple_evacuate(cap, str, hash, p);
564
565 default:
566 // This object was evacuated already, return the existing
567 // pointer
568 if (hash != NULL &&
569 (already = lookupHashTable (hash, (StgWord)from))) {
570 *p = TAG_CLOSURE(tag, (StgClosure*)already);
571 return;
572 }
573
574 copy_tag(cap, str, hash, p, from, tag);
575 }
576 }
577
578 static void
579 simple_scavenge_mut_arr_ptrs (Capability *cap,
580 StgCompactNFData *str,
581 HashTable *hash,
582 StgMutArrPtrs *a)
583 {
584 StgPtr p, q;
585
586 p = (StgPtr)&a->payload[0];
587 q = (StgPtr)&a->payload[a->ptrs];
588 for (; p < q; p++) {
589 simple_evacuate(cap, str, hash, (StgClosure**)p);
590 }
591 }
592
593 static void
594 simple_scavenge_block (Capability *cap,
595 StgCompactNFData *str,
596 StgCompactNFDataBlock *block,
597 HashTable *hash,
598 StgPtr p)
599 {
600 const StgInfoTable *info;
601 bdescr *bd = Bdescr((P_)block);
602
603 while (p < bd->free) {
604 ASSERT (LOOKS_LIKE_CLOSURE_PTR(p));
605 info = get_itbl((StgClosure*)p);
606
607 switch (info->type) {
608 case CONSTR_1_0:
609 simple_evacuate(cap, str, hash, &((StgClosure*)p)->payload[0]);
610 case CONSTR_0_1:
611 p += sizeofW(StgClosure) + 1;
612 break;
613
614 case CONSTR_2_0:
615 simple_evacuate(cap, str, hash, &((StgClosure*)p)->payload[1]);
616 case CONSTR_1_1:
617 simple_evacuate(cap, str, hash, &((StgClosure*)p)->payload[0]);
618 case CONSTR_0_2:
619 p += sizeofW(StgClosure) + 2;
620 break;
621
622 case CONSTR:
623 case PRIM:
624 case CONSTR_NOCAF:
625 {
626 StgPtr end;
627
628 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
629 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
630 simple_evacuate(cap, str, hash, (StgClosure **)p);
631 }
632 p += info->layout.payload.nptrs;
633 break;
634 }
635
636 case ARR_WORDS:
637 p += arr_words_sizeW((StgArrBytes*)p);
638 break;
639
640 case MUT_ARR_PTRS_FROZEN:
641 case MUT_ARR_PTRS_FROZEN0:
642 simple_scavenge_mut_arr_ptrs(cap, str, hash, (StgMutArrPtrs*)p);
643 p += mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
644 break;
645
646 case SMALL_MUT_ARR_PTRS_FROZEN:
647 case SMALL_MUT_ARR_PTRS_FROZEN0:
648 {
649 uint32_t i;
650 StgSmallMutArrPtrs *arr = (StgSmallMutArrPtrs*)p;
651
652 for (i = 0; i < arr->ptrs; i++)
653 simple_evacuate(cap, str, hash, &arr->payload[i]);
654
655 p += sizeofW(StgSmallMutArrPtrs) + arr->ptrs;
656 break;
657 }
658
659 case IND:
660 case BLACKHOLE:
661 case IND_STATIC:
662 // They get shortcircuited by simple_evaluate()
663 barf("IND/BLACKHOLE in Compact");
664 break;
665
666 default:
667 barf("Invalid non-NFData closure in Compact\n");
668 }
669 }
670 }
671
672 static void
673 scavenge_loop (Capability *cap,
674 StgCompactNFData *str,
675 StgCompactNFDataBlock *first_block,
676 HashTable *hash,
677 StgPtr p)
678 {
679 // Scavenge the first block
680 simple_scavenge_block(cap, str, first_block, hash, p);
681
682 // Note: simple_scavenge_block can change str->last, which
683 // changes this check, in addition to iterating through
684 while (first_block != str->last) {
685 // we can't allocate in blocks that were already scavenged
686 // so push the nursery forward
687 if (str->nursery == first_block)
688 str->nursery = str->nursery->next;
689
690 first_block = first_block->next;
691 simple_scavenge_block(cap, str, first_block, hash,
692 (P_)first_block + sizeofW(StgCompactNFDataBlock));
693 }
694 }
695
696 #ifdef DEBUG
697 static rtsBool
698 objectIsWHNFData (StgClosure *what)
699 {
700 switch (get_itbl(what)->type) {
701 case CONSTR:
702 case CONSTR_1_0:
703 case CONSTR_0_1:
704 case CONSTR_2_0:
705 case CONSTR_1_1:
706 case CONSTR_0_2:
707 case CONSTR_NOCAF:
708 case ARR_WORDS:
709 case MUT_ARR_PTRS_FROZEN:
710 case MUT_ARR_PTRS_FROZEN0:
711 case SMALL_MUT_ARR_PTRS_FROZEN:
712 case SMALL_MUT_ARR_PTRS_FROZEN0:
713 return rtsTrue;
714
715 case IND:
716 case BLACKHOLE:
717 return objectIsWHNFData(UNTAG_CLOSURE(((StgInd*)what)->indirectee));
718
719 default:
720 return rtsFalse;
721 }
722 }
723
724 static rtsBool
725 verify_mut_arr_ptrs (StgCompactNFData *str,
726 StgMutArrPtrs *a)
727 {
728 StgPtr p, q;
729
730 p = (StgPtr)&a->payload[0];
731 q = (StgPtr)&a->payload[a->ptrs];
732 for (; p < q; p++) {
733 if (!object_in_compact(str, UNTAG_CLOSURE(*(StgClosure**)p)))
734 return rtsFalse;
735 }
736
737 return rtsTrue;
738 }
739
740 static rtsBool
741 verify_consistency_block (StgCompactNFData *str, StgCompactNFDataBlock *block)
742 {
743 bdescr *bd;
744 StgPtr p;
745 const StgInfoTable *info;
746 StgClosure *q;
747
748 p = (P_)firstBlockGetCompact(block);
749 bd = Bdescr((P_)block);
750 while (p < bd->free) {
751 q = (StgClosure*)p;
752
753 if (!LOOKS_LIKE_CLOSURE_PTR(q))
754 return rtsFalse;
755
756 info = get_itbl(q);
757 switch (info->type) {
758 case CONSTR_1_0:
759 if (!object_in_compact(str, UNTAG_CLOSURE(q->payload[0])))
760 return rtsFalse;
761 case CONSTR_0_1:
762 p += sizeofW(StgClosure) + 1;
763 break;
764
765 case CONSTR_2_0:
766 if (!object_in_compact(str, UNTAG_CLOSURE(q->payload[1])))
767 return rtsFalse;
768 case CONSTR_1_1:
769 if (!object_in_compact(str, UNTAG_CLOSURE(q->payload[0])))
770 return rtsFalse;
771 case CONSTR_0_2:
772 p += sizeofW(StgClosure) + 2;
773 break;
774
775 case CONSTR:
776 case PRIM:
777 case CONSTR_NOCAF:
778 {
779 uint32_t i;
780
781 for (i = 0; i < info->layout.payload.ptrs; i++)
782 if (!object_in_compact(str, UNTAG_CLOSURE(q->payload[i])))
783 return rtsFalse;
784
785 p += sizeofW(StgClosure) + info->layout.payload.ptrs +
786 info->layout.payload.nptrs;
787 break;
788 }
789
790 case ARR_WORDS:
791 p += arr_words_sizeW((StgArrBytes*)p);
792 break;
793
794 case MUT_ARR_PTRS_FROZEN:
795 case MUT_ARR_PTRS_FROZEN0:
796 if (!verify_mut_arr_ptrs(str, (StgMutArrPtrs*)p))
797 return rtsFalse;
798 p += mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
799 break;
800
801 case SMALL_MUT_ARR_PTRS_FROZEN:
802 case SMALL_MUT_ARR_PTRS_FROZEN0:
803 {
804 uint32_t i;
805 StgSmallMutArrPtrs *arr = (StgSmallMutArrPtrs*)p;
806
807 for (i = 0; i < arr->ptrs; i++)
808 if (!object_in_compact(str, UNTAG_CLOSURE(arr->payload[i])))
809 return rtsFalse;
810
811 p += sizeofW(StgSmallMutArrPtrs) + arr->ptrs;
812 break;
813 }
814
815 case COMPACT_NFDATA:
816 p += sizeofW(StgCompactNFData);
817 break;
818
819 default:
820 return rtsFalse;
821 }
822 }
823
824 return rtsTrue;
825 }
826
827 static rtsBool
828 verify_consistency_loop (StgCompactNFData *str)
829 {
830 StgCompactNFDataBlock *block;
831
832 block = compactGetFirstBlock(str);
833 do {
834 if (!verify_consistency_block(str, block))
835 return rtsFalse;
836 block = block->next;
837 } while (block && block->owner);
838
839 return rtsTrue;
840 }
841 #endif
842
843
844 StgPtr
845 compactAppend (Capability *cap,
846 StgCompactNFData *str,
847 StgClosure *what,
848 StgWord share)
849 {
850 StgClosure *root;
851 StgClosure *tagged_root;
852 HashTable *hash;
853 StgCompactNFDataBlock *evaced_block;
854
855 ASSERT(objectIsWHNFData(UNTAG_CLOSURE(what)));
856
857 tagged_root = what;
858 simple_evacuate(cap, str, NULL, &tagged_root);
859
860 root = UNTAG_CLOSURE(tagged_root);
861 evaced_block = objectGetCompactBlock(root);
862
863 if (share) {
864 hash = allocHashTable ();
865 insertHashTable(hash, (StgWord)UNTAG_CLOSURE(what), root);
866 } else
867 hash = NULL;
868
869 scavenge_loop(cap, str, evaced_block, hash, (P_)root);
870
871 if (share)
872 freeHashTable(hash, NULL);
873
874 ASSERT(verify_consistency_loop(str));
875
876 return (StgPtr)tagged_root;
877 }
878
879 StgWord
880 compactContains (StgCompactNFData *str, StgPtr what)
881 {
882 bdescr *bd;
883
884 // This check is the reason why this needs to be
885 // implemented in C instead of (possibly faster) Cmm
886 if (!HEAP_ALLOCED (what))
887 return 0;
888
889 // Note that we don't care about tags, they are eaten
890 // away by the Bdescr operation anyway
891 bd = Bdescr((P_)what);
892 return (bd->flags & BF_COMPACT) != 0 &&
893 (str == NULL || objectGetCompact((StgClosure*)what) == str);
894 }
895
896 StgCompactNFDataBlock *
897 compactAllocateBlock(Capability *cap,
898 StgWord size,
899 StgCompactNFDataBlock *previous)
900 {
901 StgWord aligned_size;
902 StgCompactNFDataBlock *block;
903 bdescr *bd;
904
905 aligned_size = BLOCK_ROUND_UP(size);
906
907 // We do not link the new object into the generation ever
908 // - we cannot let the GC know about this object until we're done
909 // importing it and we have fixed up all info tables and stuff
910 //
911 // but we do update n_compact_blocks, otherwise memInventory()
912 // in Sanity will think we have a memory leak, because it compares
913 // the blocks he knows about with the blocks obtained by the
914 // block allocator
915 // (if by chance a memory leak does happen due to a bug somewhere
916 // else, memInventory will also report that all compact blocks
917 // associated with this compact are leaked - but they are not really,
918 // we have a pointer to them and we're not losing track of it, it's
919 // just we can't use the GC until we're done with the import)
920 //
921 // (That btw means that the high level import code must be careful
922 // not to lose the pointer, so don't use the primops directly
923 // unless you know what you're doing!)
924
925 // Other trickery: we pass NULL as first, which means our blocks
926 // are always in generation 0
927 // This is correct because the GC has never seen the blocks so
928 // it had no chance of promoting them
929
930 block = compactAllocateBlockInternal(cap, aligned_size, NULL,
931 previous != NULL ? ALLOCATE_IMPORT_APPEND : ALLOCATE_IMPORT_NEW);
932 if (previous != NULL)
933 previous->next = block;
934
935 bd = Bdescr((P_)block);
936 bd->free = (P_)((W_)bd->start + size);
937
938 return block;
939 }
940
941 STATIC_INLINE rtsBool
942 any_needs_fixup(StgCompactNFDataBlock *block)
943 {
944 // ->next pointers are always valid, even if some blocks were
945 // not allocated where we want them, because compactAllocateAt()
946 // will take care to adjust them
947
948 do {
949 if (block->self != block)
950 return rtsTrue;
951 block = block->next;
952 } while (block && block->owner);
953
954 return rtsFalse;
955 }
956
957 #ifdef DEBUG
958 static void
959 spew_failing_pointer(StgWord *fixup_table, uint32_t count, StgWord address)
960 {
961 uint32_t i;
962 StgWord key, value;
963 StgCompactNFDataBlock *block;
964 bdescr *bd;
965 StgWord size;
966
967 debugBelch("Failed to adjust 0x%" FMT_HexWord ". Block dump follows...\n",
968 address);
969
970 for (i = 0; i < count; i++) {
971 key = fixup_table [2 * i];
972 value = fixup_table [2 * i + 1];
973
974 block = (StgCompactNFDataBlock*)value;
975 bd = Bdescr((P_)block);
976 size = (W_)bd->free - (W_)bd->start;
977
978 debugBelch("%" FMT_Word32 ": was 0x%" FMT_HexWord "-0x%" FMT_HexWord
979 ", now 0x%" FMT_HexWord "-0x%" FMT_HexWord "\n", i, key,
980 key+size, value, value+size);
981 }
982 }
983 #endif
984
985 STATIC_INLINE StgCompactNFDataBlock *
986 find_pointer(StgWord *fixup_table, uint32_t count, StgClosure *q)
987 {
988 StgWord address = (W_)q;
989 uint32_t a, b, c;
990 StgWord key, value;
991 bdescr *bd;
992
993 a = 0;
994 b = count;
995 while (a < b-1) {
996 c = (a+b)/2;
997
998 key = fixup_table[c * 2];
999 value = fixup_table[c * 2 + 1];
1000
1001 if (key > address)
1002 b = c;
1003 else
1004 a = c;
1005 }
1006
1007 // three cases here: 0, 1 or 2 blocks to check
1008 for ( ; a < b; a++) {
1009 key = fixup_table[a * 2];
1010 value = fixup_table[a * 2 + 1];
1011
1012 if (key > address)
1013 goto fail;
1014
1015 bd = Bdescr((P_)value);
1016
1017 if (key + bd->blocks * BLOCK_SIZE <= address)
1018 goto fail;
1019
1020 return (StgCompactNFDataBlock*)value;
1021 }
1022
1023 fail:
1024 // We should never get here
1025
1026 #ifdef DEBUG
1027 spew_failing_pointer(fixup_table, count, address);
1028 #endif
1029 return NULL;
1030 }
1031
1032 static rtsBool
1033 fixup_one_pointer(StgWord *fixup_table, uint32_t count, StgClosure **p)
1034 {
1035 StgWord tag;
1036 StgClosure *q;
1037 StgCompactNFDataBlock *block;
1038
1039 q = *p;
1040 tag = GET_CLOSURE_TAG(q);
1041 q = UNTAG_CLOSURE(q);
1042
1043 block = find_pointer(fixup_table, count, q);
1044 if (block == NULL)
1045 return rtsFalse;
1046 if (block == block->self)
1047 return rtsTrue;
1048
1049 q = (StgClosure*)((W_)q - (W_)block->self + (W_)block);
1050 *p = TAG_CLOSURE(tag, q);
1051
1052 return rtsTrue;
1053 }
1054
1055 static rtsBool
1056 fixup_mut_arr_ptrs (StgWord *fixup_table,
1057 uint32_t count,
1058 StgMutArrPtrs *a)
1059 {
1060 StgPtr p, q;
1061
1062 p = (StgPtr)&a->payload[0];
1063 q = (StgPtr)&a->payload[a->ptrs];
1064 for (; p < q; p++) {
1065 if (!fixup_one_pointer(fixup_table, count, (StgClosure**)p))
1066 return rtsFalse;
1067 }
1068
1069 return rtsTrue;
1070 }
1071
1072 static rtsBool
1073 fixup_block(StgCompactNFDataBlock *block, StgWord *fixup_table, uint32_t count)
1074 {
1075 const StgInfoTable *info;
1076 bdescr *bd;
1077 StgPtr p;
1078
1079 bd = Bdescr((P_)block);
1080 p = bd->start + sizeofW(StgCompactNFDataBlock);
1081 while (p < bd->free) {
1082 ASSERT (LOOKS_LIKE_CLOSURE_PTR(p));
1083 info = get_itbl((StgClosure*)p);
1084
1085 switch (info->type) {
1086 case CONSTR_1_0:
1087 if (!fixup_one_pointer(fixup_table, count,
1088 &((StgClosure*)p)->payload[0]))
1089 return rtsFalse;
1090 case CONSTR_0_1:
1091 p += sizeofW(StgClosure) + 1;
1092 break;
1093
1094 case CONSTR_2_0:
1095 if (!fixup_one_pointer(fixup_table, count,
1096 &((StgClosure*)p)->payload[1]))
1097 return rtsFalse;
1098 case CONSTR_1_1:
1099 if (!fixup_one_pointer(fixup_table, count,
1100 &((StgClosure*)p)->payload[0]))
1101 return rtsFalse;
1102 case CONSTR_0_2:
1103 p += sizeofW(StgClosure) + 2;
1104 break;
1105
1106 case CONSTR:
1107 case PRIM:
1108 case CONSTR_NOCAF:
1109 {
1110 StgPtr end;
1111
1112 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
1113 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
1114 if (!fixup_one_pointer(fixup_table, count, (StgClosure **)p))
1115 return rtsFalse;
1116 }
1117 p += info->layout.payload.nptrs;
1118 break;
1119 }
1120
1121 case ARR_WORDS:
1122 p += arr_words_sizeW((StgArrBytes*)p);
1123 break;
1124
1125 case MUT_ARR_PTRS_FROZEN:
1126 case MUT_ARR_PTRS_FROZEN0:
1127 fixup_mut_arr_ptrs(fixup_table, count, (StgMutArrPtrs*)p);
1128 p += mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1129 break;
1130
1131 case SMALL_MUT_ARR_PTRS_FROZEN:
1132 case SMALL_MUT_ARR_PTRS_FROZEN0:
1133 {
1134 uint32_t i;
1135 StgSmallMutArrPtrs *arr = (StgSmallMutArrPtrs*)p;
1136
1137 for (i = 0; i < arr->ptrs; i++) {
1138 if (!fixup_one_pointer(fixup_table, count,
1139 &arr->payload[i]))
1140 return rtsFalse;
1141 }
1142
1143 p += sizeofW(StgSmallMutArrPtrs) + arr->ptrs;
1144 break;
1145 }
1146
1147 case COMPACT_NFDATA:
1148 if (p == (bd->start + sizeofW(StgCompactNFDataBlock))) {
1149 // Ignore the COMPACT_NFDATA header
1150 // (it will be fixed up later)
1151 p += sizeofW(StgCompactNFData);
1152 break;
1153 }
1154
1155 // fall through
1156
1157 default:
1158 debugBelch("Invalid non-NFData closure (type %d) in Compact\n",
1159 info->type);
1160 return rtsFalse;
1161 }
1162 }
1163
1164 return rtsTrue;
1165 }
1166
1167 static int
1168 cmp_fixup_table_item (const void *e1, const void *e2)
1169 {
1170 const StgWord *w1 = e1;
1171 const StgWord *w2 = e2;
1172
1173 return *w1 - *w2;
1174 }
1175
1176 static StgWord *
1177 build_fixup_table (StgCompactNFDataBlock *block, uint32_t *pcount)
1178 {
1179 uint32_t count;
1180 StgCompactNFDataBlock *tmp;
1181 StgWord *table;
1182
1183 count = 0;
1184 tmp = block;
1185 do {
1186 count++;
1187 tmp = tmp->next;
1188 } while(tmp && tmp->owner);
1189
1190 table = stgMallocBytes(sizeof(StgWord) * 2 * count, "build_fixup_table");
1191
1192 count = 0;
1193 do {
1194 table[count * 2] = (W_)block->self;
1195 table[count * 2 + 1] = (W_)block;
1196 count++;
1197 block = block->next;
1198 } while(block && block->owner);
1199
1200 qsort(table, count, sizeof(StgWord) * 2, cmp_fixup_table_item);
1201
1202 *pcount = count;
1203 return table;
1204 }
1205
1206 static rtsBool
1207 fixup_loop(StgCompactNFDataBlock *block, StgClosure **proot)
1208 {
1209 StgWord *table;
1210 rtsBool ok;
1211 uint32_t count;
1212
1213 table = build_fixup_table (block, &count);
1214
1215 do {
1216 if (!fixup_block(block, table, count)) {
1217 ok = rtsFalse;
1218 goto out;
1219 }
1220
1221 block = block->next;
1222 } while(block && block->owner);
1223
1224 ok = fixup_one_pointer(table, count, proot);
1225
1226 out:
1227 stgFree(table);
1228 return ok;
1229 }
1230
1231 static void
1232 fixup_early(StgCompactNFData *str, StgCompactNFDataBlock *block)
1233 {
1234 StgCompactNFDataBlock *last;
1235
1236 do {
1237 last = block;
1238 block = block->next;
1239 } while(block);
1240
1241 str->last = last;
1242 }
1243
1244 static void
1245 fixup_late(StgCompactNFData *str, StgCompactNFDataBlock *block)
1246 {
1247 StgCompactNFDataBlock *nursery;
1248 bdescr *bd;
1249 StgWord totalW;
1250 StgWord totalDataW;
1251
1252 nursery = block;
1253 totalW = 0;
1254 totalDataW = 0;
1255 do {
1256 block->self = block;
1257
1258 bd = Bdescr((P_)block);
1259 totalW += bd->blocks * BLOCK_SIZE_W;
1260
1261 if (block->owner != NULL) {
1262 if (bd->free != bd->start)
1263 nursery = block;
1264 block->owner = str;
1265 totalDataW += bd->blocks * BLOCK_SIZE_W;
1266 }
1267
1268 block = block->next;
1269 } while(block);
1270
1271 str->nursery = nursery;
1272 str->totalW = totalW;
1273 str->totalDataW = totalDataW;
1274 }
1275
1276 static StgClosure *
1277 maybe_fixup_internal_pointers (StgCompactNFDataBlock *block,
1278 StgClosure *root)
1279 {
1280 rtsBool ok;
1281 StgClosure **proot;
1282
1283 // Check for fast path
1284 if (!any_needs_fixup(block))
1285 return root;
1286
1287 debugBelch("Compact imported at the wrong address, will fix up"
1288 " internal pointers\n");
1289
1290 // I am PROOT!
1291 proot = &root;
1292
1293 ok = fixup_loop(block, proot);
1294 if (!ok)
1295 *proot = NULL;
1296
1297 return *proot;
1298 }
1299
1300 StgPtr
1301 compactFixupPointers(StgCompactNFData *str,
1302 StgClosure *root)
1303 {
1304 StgCompactNFDataBlock *block;
1305 bdescr *bd;
1306 StgWord total_blocks;
1307
1308 block = compactGetFirstBlock(str);
1309
1310 fixup_early(str, block);
1311
1312 root = maybe_fixup_internal_pointers(block, root);
1313
1314 // Do the late fixup even if we did not fixup all
1315 // internal pointers, we need that for GC and Sanity
1316 fixup_late(str, block);
1317
1318 // Now we're ready to let the GC, Sanity, the profiler
1319 // etc. know about this object
1320 bd = Bdescr((P_)block);
1321
1322 total_blocks = str->totalW / BLOCK_SIZE_W;
1323
1324 ACQUIRE_SM_LOCK;
1325 ASSERT (bd->gen == g0);
1326 ASSERT (g0->n_compact_blocks_in_import >= total_blocks);
1327 g0->n_compact_blocks_in_import -= total_blocks;
1328 g0->n_compact_blocks += total_blocks;
1329 dbl_link_remove(bd, &g0->compact_blocks_in_import);
1330 dbl_link_onto(bd, &g0->compact_objects);
1331 RELEASE_SM_LOCK;
1332
1333 #if DEBUG
1334 if (root)
1335 verify_consistency_loop(str);
1336 #endif
1337
1338 return (StgPtr)root;
1339 }