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