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