Remove explicit recursion in retainer profiling (fixes #14758)
[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_FROZEN_DIRTY,
158         MUT_ARR_PTRS_FROZEN_CLEAN: {
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_FROZEN_DIRTY,
190         SMALL_MUT_ARR_PTRS_FROZEN_CLEAN: {
191
192         (should) = ccall shouldCompact(compact "ptr", p "ptr");
193         if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = p; return(); }
194
195         CHECK_HASH();
196
197         W_ i, ptrs;
198         ptrs = StgSmallMutArrPtrs_ptrs(p);
199         ALLOCATE(compact, BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + ptrs, p, to, tag);
200         P_[pp] = tag | to;
201         SET_HDR(to, StgHeader_info(p), StgHeader_ccs(p));
202         StgSmallMutArrPtrs_ptrs(to) = ptrs;
203         i = 0;
204       loop1:
205         if (i < ptrs) ( likely: True ) {
206             W_ q;
207             q = to + SIZEOF_StgSmallMutArrPtrs + WDS(i);
208             call stg_compactAddWorkerzh(
209                 compact, P_[p + SIZEOF_StgSmallMutArrPtrs + WDS(i)], q);
210             i = i + 1;
211             goto loop1;
212         }
213         return();
214     }
215
216     // Everything else we should copy and evaluate the components:
217     case
218         CONSTR,
219         CONSTR_1_0,
220         CONSTR_2_0,
221         CONSTR_1_1: {
222
223         (should) = ccall shouldCompact(compact "ptr", p "ptr");
224         if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = p; return(); }
225
226       constructor:
227
228         CHECK_HASH();
229
230         W_ i, ptrs, nptrs, size;
231         P_ to;
232         ptrs  = TO_W_(%INFO_PTRS(%STD_INFO(info)));
233         nptrs  = TO_W_(%INFO_NPTRS(%STD_INFO(info)));
234         size = BYTES_TO_WDS(SIZEOF_StgHeader) + ptrs + nptrs;
235
236         ALLOCATE(compact, size, p, to, tag);
237         P_[pp] = tag | to;
238         SET_HDR(to, StgHeader_info(p), StgHeader_ccs(p));
239
240         // First, copy the non-pointers
241         if (nptrs > 0) {
242             i = ptrs;
243         loop2:
244             StgClosure_payload(to,i) = StgClosure_payload(p,i);
245             i = i + 1;
246             if (i < ptrs + nptrs) ( likely: True ) goto loop2;
247         }
248
249         // Next, recursively compact and copy the pointers
250         if (ptrs == 0) { return(); }
251         i = 0;
252       loop3:
253         W_ q;
254         q = to + SIZEOF_StgHeader + OFFSET_StgClosure_payload + WDS(i);
255         // Tail-call the last one.  This means we don't build up a deep
256         // stack when compacting lists.
257         if (i == ptrs - 1) {
258             jump stg_compactAddWorkerzh(compact, StgClosure_payload(p,i), q);
259         }
260         call stg_compactAddWorkerzh(compact, StgClosure_payload(p,i), q);
261         i = i + 1;
262         goto loop3;
263     }
264
265     // these might be static closures that we can avoid copying into
266     // the compact if they don't refer to CAFs.
267     case
268         CONSTR_0_1,
269         CONSTR_0_2,
270         CONSTR_NOCAF: {
271
272         (should) = ccall shouldCompact(compact "ptr", p "ptr");
273         if (should == SHOULDCOMPACT_IN_CNF ||
274             should == SHOULDCOMPACT_STATIC) { P_[pp] = p; return(); }
275
276         goto constructor;
277     }}
278
279     ccall barf("stg_compactWorkerzh");
280 }
281
282 //
283 // compactAddWithSharing#
284 //   :: State# RealWorld
285 //   -> Compact#
286 //   -> a
287 //   -> (# State# RealWorld, a #)
288 //
289 stg_compactAddWithSharingzh (P_ compact, P_ p)
290 {
291     W_ hash;
292     ASSERT(StgCompactNFData_hash(compact) == NULL);
293     (hash) = ccall allocHashTable();
294     StgCompactNFData_hash(compact) = hash;
295
296     // Note [compactAddWorker result]
297     //
298     // compactAddWorker needs somewhere to store the result - this is
299     // so that it can be tail-recursive.  It must be an address that
300     // doesn't move during GC, so we can't use heap or stack.
301     // Therefore we have a special field in the StgCompactNFData
302     // object to hold the final result of compaction.
303     W_ pp;
304     pp = compact + SIZEOF_StgHeader + OFFSET_StgCompactNFData_result;
305     call stg_compactAddWorkerzh(compact, p, pp);
306     ccall freeHashTable(StgCompactNFData_hash(compact), NULL);
307     StgCompactNFData_hash(compact) = NULL;
308 #if defined(DEBUG)
309     ccall verifyCompact(compact);
310 #endif
311     return (P_[pp]);
312 }
313
314 //
315 // compactAdd#
316 //   :: State# RealWorld
317 //   -> Compact#
318 //   -> a
319 //   -> (# State# RealWorld, a #)
320 //
321 stg_compactAddzh (P_ compact, P_ p)
322 {
323     ASSERT(StgCompactNFData_hash(compact) == NULL);
324
325     W_ pp; // See Note [compactAddWorker result]
326     pp = compact + SIZEOF_StgHeader + OFFSET_StgCompactNFData_result;
327     call stg_compactAddWorkerzh(compact, p, pp);
328 #if defined(DEBUG)
329     ccall verifyCompact(compact);
330 #endif
331     return (P_[pp]);
332 }
333
334 stg_compactSizzezh (P_ compact)
335 {
336    return (StgCompactNFData_totalW(compact) * SIZEOF_W);
337 }
338
339 stg_compactNewzh ( W_ size )
340 {
341     P_ str;
342
343     again: MAYBE_GC(again);
344
345     ("ptr" str) = ccall compactNew(MyCapability() "ptr", size);
346     return (str);
347 }
348
349 stg_compactResizzezh ( P_ str, W_ new_size )
350 {
351     again: MAYBE_GC(again);
352
353     ccall compactResize(MyCapability() "ptr", str "ptr", new_size);
354     return ();
355 }
356
357 stg_compactContainszh ( P_ str, P_ val )
358 {
359     W_ rval;
360
361     (rval) = ccall compactContains(str "ptr", val "ptr");
362     return (rval);
363 }
364
365 stg_compactContainsAnyzh ( P_ val )
366 {
367     W_ rval;
368
369     (rval) = ccall compactContains(0 "ptr", val "ptr");
370     return (rval);
371 }
372
373 stg_compactGetFirstBlockzh ( P_ str )
374 {
375     /* W_, not P_, because it is not a gc pointer */
376     W_ block;
377     W_ bd;
378     W_ size;
379
380     block = str - SIZEOF_StgCompactNFDataBlock::W_;
381     ASSERT(StgCompactNFDataBlock_owner(block) == str);
382
383     // We have to save Hp back to the nursery, otherwise the size will
384     // be wrong.
385     bd = Bdescr(StgCompactNFData_nursery(str));
386     bdescr_free(bd) = StgCompactNFData_hp(str);
387
388     bd = Bdescr(str);
389     size = bdescr_free(bd) - bdescr_start(bd);
390     ASSERT(size <= TO_W_(bdescr_blocks(bd)) * BLOCK_SIZE);
391
392     return (block, size);
393 }
394
395 stg_compactGetNextBlockzh ( P_ str, W_ block )
396 {
397     /* str is a pointer to the closure holding the Compact#
398        it is there primarily to keep everything reachable from
399        the GC: by having it on the stack of type P_, the GC will
400        see all the blocks as live (any pointer in the Compact#
401        keeps it alive), and will not collect the block
402        We don't run a GC inside this primop, but it could
403        happen right after, or we could be preempted.
404
405        str is also useful for debugging, as it can be casted
406        to a useful C struct from the gdb command line and all
407        blocks can be inspected
408     */
409     W_ bd;
410     W_ next_block;
411     W_ size;
412
413     next_block = StgCompactNFDataBlock_next(block);
414
415     if (next_block == 0::W_) {
416         return (0::W_, 0::W_);
417     }
418
419     ASSERT(StgCompactNFDataBlock_owner(next_block) == str ||
420             StgCompactNFDataBlock_owner(next_block) == NULL);
421
422     bd = Bdescr(next_block);
423     size = bdescr_free(bd) - bdescr_start(bd);
424     ASSERT(size <= TO_W_(bdescr_blocks(bd)) * BLOCK_SIZE);
425
426     return (next_block, size);
427 }
428
429 stg_compactAllocateBlockzh ( W_ size, W_ previous )
430 {
431     W_ actual_block;
432
433     again: MAYBE_GC(again);
434
435     ("ptr" actual_block) = ccall compactAllocateBlock(MyCapability(),
436                                                       size,
437                                                       previous "ptr");
438
439     return (actual_block);
440 }
441
442 stg_compactFixupPointerszh ( W_ first_block, W_ root )
443 {
444     W_ str;
445     P_ gcstr;
446     W_ ok;
447
448     str = first_block + SIZEOF_StgCompactNFDataBlock::W_;
449     (ok) = ccall compactFixupPointers (str "ptr", root "ptr");
450
451     // Now we can let the GC know about str, because it was linked
452     // into the generation list and the book-keeping pointers are
453     // guaranteed to be valid
454     // (this is true even if the fixup phase failed)
455     gcstr = str;
456     return (gcstr, ok);
457 }