rts/RetainerProfile: Dump closure type if push() fails
[ghc.git] / rts / Compact.cmm
1 /* -----------------------------------------------------------------------------
2  *
3  * (c) The GHC Team, 2015-2016
4  *
5  * Support for compact regions.  See Note [Compact Normal Forms] in
6  * rts/sm/CNF.c
7  *
8  * ---------------------------------------------------------------------------*/
9
10 #include "Cmm.h"
11 #include "sm/ShouldCompact.h"
12
13 import CLOSURE base_GHCziIOziException_cannotCompactFunction_closure;
14 import CLOSURE base_GHCziIOziException_cannotCompactMutable_closure;
15 import CLOSURE base_GHCziIOziException_cannotCompactPinned_closure;
16
17 //
18 // Allocate space for a new object in the compact region.  We first try
19 // the fast method using the hp/hpLim fields of StgCompactNFData, and
20 // if that fails we fall back to calling allocateForCompact() which
21 // will append a new block if necessary.
22 //
23 #define ALLOCATE(compact,sizeW,p,to, tag)                               \
24     hp = StgCompactNFData_hp(compact);                                  \
25     if (hp + WDS(sizeW) <= StgCompactNFData_hpLim(compact)) {           \
26         to = hp;                                                        \
27         StgCompactNFData_hp(compact) = hp + WDS(sizeW);                 \
28     } else {                                                            \
29         ("ptr" to) = ccall allocateForCompact(                          \
30             MyCapability() "ptr", compact "ptr", sizeW);                \
31     }                                                                   \
32     if (StgCompactNFData_hash(compact) != NULL) {                       \
33         ccall insertCompactHash(MyCapability(), compact, p, tag | to);  \
34     }
35
36
37 //
38 // Look up a pointer in the hash table if we're doing sharing.
39 //
40 #define CHECK_HASH()                                                    \
41     hash = StgCompactNFData_hash(compact);                              \
42     if (hash != NULL) {                                                 \
43         ("ptr" hashed) = ccall lookupHashTable(hash "ptr", p "ptr");    \
44         if (hashed != NULL) {                                           \
45             P_[pp] = hashed;                                            \
46             return ();                                                  \
47         }                                                               \
48     }
49
50 //
51 // Evacuate and copy an object and its transitive closure into a
52 // compact.  This function is called recursively as we traverse the
53 // data structure.  It takes the location to store the address of the
54 // compacted object as an argument, so that it can be tail-recursive.
55 //
56 stg_compactAddWorkerzh (
57     P_ compact,  // The Compact# object
58     P_ p,        // The object to compact
59     W_ pp)       // Where to store a pointer to the compacted object
60 {
61     W_ type, info, should, hash, hp, tag;
62     P_ p;
63     P_ hashed;
64
65     again: MAYBE_GC(again);
66     STK_CHK_GEN();
67
68 eval:
69     tag = GETTAG(p);
70     p = UNTAG(p);
71     info  = %INFO_PTR(p);
72     type = TO_W_(%INFO_TYPE(%STD_INFO(info)));
73
74     switch [0 .. N_CLOSURE_TYPES] type {
75
76     // Unevaluated things must be evaluated first:
77     case
78         THUNK,
79         THUNK_1_0,
80         THUNK_0_1,
81         THUNK_2_0,
82         THUNK_1_1,
83         THUNK_0_2,
84         THUNK_STATIC,
85         AP,
86         AP_STACK,
87         BLACKHOLE,
88         THUNK_SELECTOR : {
89         (P_ evald) = call %ENTRY_CODE(info) (p);
90         p = evald;
91         goto eval;
92     }
93
94     // Follow indirections:
95     case IND, IND_STATIC: {
96         p = StgInd_indirectee(p);
97         goto eval;
98     }
99
100     // Mutable things are not allowed:
101     case
102         MVAR_CLEAN,
103         MVAR_DIRTY,
104         TVAR,
105         MUT_ARR_PTRS_CLEAN,
106         MUT_ARR_PTRS_DIRTY,
107         MUT_ARR_PTRS_CLEAN,
108         MUT_VAR_CLEAN,
109         MUT_VAR_DIRTY,
110         WEAK,
111         PRIM,
112         MUT_PRIM,
113         TSO,
114         STACK,
115         TREC_CHUNK,
116         WHITEHOLE,
117         SMALL_MUT_ARR_PTRS_CLEAN,
118         SMALL_MUT_ARR_PTRS_DIRTY,
119         COMPACT_NFDATA: {
120         jump stg_raisezh(base_GHCziIOziException_cannotCompactMutable_closure);
121     }
122
123     // We shouldn't see any functions, if this data structure was NFData.
124     case
125         FUN,
126         FUN_1_0,
127         FUN_0_1,
128         FUN_2_0,
129         FUN_1_1,
130         FUN_0_2,
131         FUN_STATIC,
132         BCO,
133         PAP: {
134         jump stg_raisezh(base_GHCziIOziException_cannotCompactFunction_closure);
135     }
136
137     case ARR_WORDS: {
138
139         (should) = ccall shouldCompact(compact "ptr", p "ptr");
140         if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = p; return(); }
141         if (should == SHOULDCOMPACT_PINNED) {
142             jump stg_raisezh(base_GHCziIOziException_cannotCompactPinned_closure);
143         }
144
145         CHECK_HASH();
146
147         P_ to;
148         W_ size;
149         size = SIZEOF_StgArrBytes + StgArrBytes_bytes(p);
150         ALLOCATE(compact, ROUNDUP_BYTES_TO_WDS(size), p, to, tag);
151         P_[pp] = to;
152         prim %memcpy(to, p, size, 1);
153         return();
154     }
155
156     case
157         MUT_ARR_PTRS_FROZEN0,
158         MUT_ARR_PTRS_FROZEN: {
159
160         (should) = ccall shouldCompact(compact "ptr", p "ptr");
161         if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = p; return(); }
162
163         CHECK_HASH();
164
165         W_ i, size, cards, ptrs;
166         size = SIZEOF_StgMutArrPtrs + WDS(StgMutArrPtrs_size(p));
167         ptrs = StgMutArrPtrs_ptrs(p);
168         cards = SIZEOF_StgMutArrPtrs + WDS(ptrs);
169         ALLOCATE(compact, BYTES_TO_WDS(size), p, to, tag);
170         P_[pp] = tag | to;
171         SET_HDR(to, StgHeader_info(p), StgHeader_ccs(p));
172         StgMutArrPtrs_ptrs(to) = ptrs;
173         StgMutArrPtrs_size(to) = StgMutArrPtrs_size(p);
174         prim %memcpy(to + cards, p + cards , size - cards, 1);
175         i = 0;
176       loop0:
177         if (i < ptrs) ( likely: True ) {
178             W_ q;
179             q = to + SIZEOF_StgMutArrPtrs + WDS(i);
180             call stg_compactAddWorkerzh(
181                 compact, P_[p + SIZEOF_StgMutArrPtrs + WDS(i)], q);
182             i = i + 1;
183             goto loop0;
184         }
185         return();
186     }
187
188     case
189         SMALL_MUT_ARR_PTRS_FROZEN0,
190         SMALL_MUT_ARR_PTRS_FROZEN: {
191
192         W_ i, size, ptrs;
193         size = SIZEOF_StgMutArrPtrs + WDS(StgMutArrPtrs_size(p));
194         ptrs = StgMutArrPtrs_ptrs(p);
195         ALLOCATE(compact, BYTES_TO_WDS(size), p, to, tag);
196         P_[pp] = tag | to;
197         SET_HDR(to, StgHeader_info(p), StgHeader_ccs(p));
198         StgMutArrPtrs_ptrs(to) = ptrs;
199         StgMutArrPtrs_size(to) = StgMutArrPtrs_size(p);
200         prim %memcpy(to, p, size, 1);
201         i = 0;
202       loop0:
203         if (i < ptrs) ( likely: True ) {
204             W_ q;
205             q = to + SIZEOF_StgSmallMutArrPtrs + WDS(i);
206             call stg_compactAddWorkerzh(
207                 compact, P_[p + SIZEOF_StgSmallMutArrPtrs + WDS(i)], q);
208             i = i + 1;
209             goto loop0;
210         }
211         return();
212     }
213
214     // Everything else we should copy and evaluate the components:
215     case
216         CONSTR,
217         CONSTR_1_0,
218         CONSTR_2_0,
219         CONSTR_1_1: {
220
221         (should) = ccall shouldCompact(compact "ptr", p "ptr");
222         if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = p; return(); }
223
224       constructor:
225
226         CHECK_HASH();
227
228         W_ i, ptrs, nptrs, size;
229         P_ to;
230         ptrs  = TO_W_(%INFO_PTRS(%STD_INFO(info)));
231         nptrs  = TO_W_(%INFO_NPTRS(%STD_INFO(info)));
232         size = BYTES_TO_WDS(SIZEOF_StgHeader) + ptrs + nptrs;
233
234         ALLOCATE(compact, size, p, to, tag);
235         P_[pp] = tag | to;
236         SET_HDR(to, StgHeader_info(p), StgHeader_ccs(p));
237
238         // First, copy the non-pointers
239         if (nptrs > 0) {
240             i = ptrs;
241         loop1:
242             StgClosure_payload(to,i) = StgClosure_payload(p,i);
243             i = i + 1;
244             if (i < ptrs + nptrs) ( likely: True ) goto loop1;
245         }
246
247         // Next, recursively compact and copy the pointers
248         if (ptrs == 0) { return(); }
249         i = 0;
250       loop2:
251         W_ q;
252         q = to + SIZEOF_StgHeader + OFFSET_StgClosure_payload + WDS(i);
253         // Tail-call the last one.  This means we don't build up a deep
254         // stack when compacting lists.
255         if (i == ptrs - 1) {
256             jump stg_compactAddWorkerzh(compact, StgClosure_payload(p,i), q);
257         }
258         call stg_compactAddWorkerzh(compact, StgClosure_payload(p,i), q);
259         i = i + 1;
260         goto loop2;
261     }
262
263     // these might be static closures that we can avoid copying into
264     // the compact if they don't refer to CAFs.
265     case
266         CONSTR_0_1,
267         CONSTR_0_2,
268         CONSTR_NOCAF: {
269
270         (should) = ccall shouldCompact(compact "ptr", p "ptr");
271         if (should == SHOULDCOMPACT_IN_CNF ||
272             should == SHOULDCOMPACT_STATIC) { P_[pp] = p; return(); }
273
274         goto constructor;
275     }}
276
277     ccall barf("stg_compactWorkerzh");
278 }
279
280 //
281 // compactAddWithSharing#
282 //   :: State# RealWorld
283 //   -> Compact#
284 //   -> a
285 //   -> (# State# RealWorld, a #)
286 //
287 stg_compactAddWithSharingzh (P_ compact, P_ p)
288 {
289     W_ hash;
290     ASSERT(StgCompactNFData_hash(compact) == NULL);
291     (hash) = ccall allocHashTable();
292     StgCompactNFData_hash(compact) = hash;
293
294     // Note [compactAddWorker result]
295     //
296     // compactAddWorker needs somewhere to store the result - this is
297     // so that it can be tail-recursive.  It must be an address that
298     // doesn't move during GC, so we can't use heap or stack.
299     // Therefore we have a special field in the StgCompactNFData
300     // object to hold the final result of compaction.
301     W_ pp;
302     pp = compact + SIZEOF_StgHeader + OFFSET_StgCompactNFData_result;
303     call stg_compactAddWorkerzh(compact, p, pp);
304     ccall freeHashTable(StgCompactNFData_hash(compact), NULL);
305     StgCompactNFData_hash(compact) = NULL;
306 #if defined(DEBUG)
307     ccall verifyCompact(compact);
308 #endif
309     return (P_[pp]);
310 }
311
312 //
313 // compactAdd#
314 //   :: State# RealWorld
315 //   -> Compact#
316 //   -> a
317 //   -> (# State# RealWorld, a #)
318 //
319 stg_compactAddzh (P_ compact, P_ p)
320 {
321     ASSERT(StgCompactNFData_hash(compact) == NULL);
322
323     W_ pp; // See Note [compactAddWorker result]
324     pp = compact + SIZEOF_StgHeader + OFFSET_StgCompactNFData_result;
325     call stg_compactAddWorkerzh(compact, p, pp);
326 #if defined(DEBUG)
327     ccall verifyCompact(compact);
328 #endif
329     return (P_[pp]);
330 }
331
332 stg_compactSizzezh (P_ compact)
333 {
334    return (StgCompactNFData_totalW(compact) * SIZEOF_W);
335 }
336
337 stg_compactNewzh ( W_ size )
338 {
339     P_ str;
340
341     again: MAYBE_GC(again);
342
343     ("ptr" str) = ccall compactNew(MyCapability() "ptr", size);
344     return (str);
345 }
346
347 stg_compactResizzezh ( P_ str, W_ new_size )
348 {
349     again: MAYBE_GC(again);
350
351     ccall compactResize(MyCapability() "ptr", str "ptr", new_size);
352     return ();
353 }
354
355 stg_compactContainszh ( P_ str, P_ val )
356 {
357     W_ rval;
358
359     (rval) = ccall compactContains(str "ptr", val "ptr");
360     return (rval);
361 }
362
363 stg_compactContainsAnyzh ( P_ val )
364 {
365     W_ rval;
366
367     (rval) = ccall compactContains(0 "ptr", val "ptr");
368     return (rval);
369 }
370
371 stg_compactGetFirstBlockzh ( P_ str )
372 {
373     /* W_, not P_, because it is not a gc pointer */
374     W_ block;
375     W_ bd;
376     W_ size;
377
378     block = str - SIZEOF_StgCompactNFDataBlock::W_;
379     ASSERT(StgCompactNFDataBlock_owner(block) == str);
380
381     // We have to save Hp back to the nursery, otherwise the size will
382     // be wrong.
383     bd = Bdescr(StgCompactNFData_nursery(str));
384     bdescr_free(bd) = StgCompactNFData_hp(str);
385
386     bd = Bdescr(str);
387     size = bdescr_free(bd) - bdescr_start(bd);
388     ASSERT(size <= TO_W_(bdescr_blocks(bd)) * BLOCK_SIZE);
389
390     return (block, size);
391 }
392
393 stg_compactGetNextBlockzh ( P_ str, W_ block )
394 {
395     /* str is a pointer to the closure holding the Compact#
396        it is there primarily to keep everything reachable from
397        the GC: by having it on the stack of type P_, the GC will
398        see all the blocks as live (any pointer in the Compact#
399        keeps it alive), and will not collect the block
400        We don't run a GC inside this primop, but it could
401        happen right after, or we could be preempted.
402
403        str is also useful for debugging, as it can be casted
404        to a useful C struct from the gdb command line and all
405        blocks can be inspected
406     */
407     W_ bd;
408     W_ next_block;
409     W_ size;
410
411     next_block = StgCompactNFDataBlock_next(block);
412
413     if (next_block == 0::W_) {
414         return (0::W_, 0::W_);
415     }
416
417     ASSERT(StgCompactNFDataBlock_owner(next_block) == str ||
418             StgCompactNFDataBlock_owner(next_block) == NULL);
419
420     bd = Bdescr(next_block);
421     size = bdescr_free(bd) - bdescr_start(bd);
422     ASSERT(size <= TO_W_(bdescr_blocks(bd)) * BLOCK_SIZE);
423
424     return (next_block, size);
425 }
426
427 stg_compactAllocateBlockzh ( W_ size, W_ previous )
428 {
429     W_ actual_block;
430
431     again: MAYBE_GC(again);
432
433     ("ptr" actual_block) = ccall compactAllocateBlock(MyCapability(),
434                                                       size,
435                                                       previous "ptr");
436
437     return (actual_block);
438 }
439
440 stg_compactFixupPointerszh ( W_ first_block, W_ root )
441 {
442     W_ str;
443     P_ gcstr;
444     W_ ok;
445
446     str = first_block + SIZEOF_StgCompactNFDataBlock::W_;
447     (ok) = ccall compactFixupPointers (str "ptr", root "ptr");
448
449     // Now we can let the GC know about str, because it was linked
450     // into the generation list and the book-keeping pointers are
451     // guaranteed to be valid
452     // (this is true even if the fixup phase failed)
453     gcstr = str;
454     return (gcstr, ok);
455 }