Merge branch 'master' of http://darcs.haskell.org/ghc
[ghc.git] / includes / rts / storage / ClosureMacros.h
1 /* ----------------------------------------------------------------------------
2 *
3 * (c) The GHC Team, 1998-2004
4 *
5 * Macros for building and manipulating closures
6 *
7 * -------------------------------------------------------------------------- */
8
9 #ifndef RTS_STORAGE_CLOSUREMACROS_H
10 #define RTS_STORAGE_CLOSUREMACROS_H
11
12 /* -----------------------------------------------------------------------------
13 Info tables are slammed up against the entry code, and the label
14 for the info table is at the *end* of the table itself. This
15 inline function adjusts an info pointer to point to the beginning
16 of the table, so we can use standard C structure indexing on it.
17
18 Note: this works for SRT info tables as long as you don't want to
19 access the SRT, since they are laid out the same with the SRT
20 pointer as the first word in the table.
21
22 NOTES ABOUT MANGLED C VS. MINI-INTERPRETER:
23
24 A couple of definitions:
25
26 "info pointer" The first word of the closure. Might point
27 to either the end or the beginning of the
28 info table, depending on whether we're using
29 the mini interpretter or not. GET_INFO(c)
30 retrieves the info pointer of a closure.
31
32 "info table" The info table structure associated with a
33 closure. This is always a pointer to the
34 beginning of the structure, so we can
35 use standard C structure indexing to pull out
36 the fields. get_itbl(c) returns a pointer to
37 the info table for closure c.
38
39 An address of the form xxxx_info points to the end of the info
40 table or the beginning of the info table depending on whether we're
41 mangling or not respectively. So,
42
43 c->header.info = xxx_info
44
45 makes absolute sense, whether mangling or not.
46
47 -------------------------------------------------------------------------- */
48
49 #define SET_INFO(c,i) ((c)->header.info = (i))
50 #define GET_INFO(c) ((c)->header.info)
51 #define GET_ENTRY(c) (ENTRY_CODE(GET_INFO(c)))
52
53 #define GET_TAG(con) (get_itbl(con)->srt_bitmap)
54
55 #ifdef TABLES_NEXT_TO_CODE
56 EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info);
57 EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgInfoTable *)info - 1;}
58 EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info);
59 EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgRetInfoTable *)info - 1;}
60 INLINE_HEADER StgFunInfoTable *FUN_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgFunInfoTable *)info - 1;}
61 INLINE_HEADER StgThunkInfoTable *THUNK_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgThunkInfoTable *)info - 1;}
62 INLINE_HEADER StgConInfoTable *CON_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgConInfoTable *)info - 1;}
63 INLINE_HEADER StgFunInfoTable *itbl_to_fun_itbl(const StgInfoTable *i) {return (StgFunInfoTable *)(i + 1) - 1;}
64 INLINE_HEADER StgRetInfoTable *itbl_to_ret_itbl(const StgInfoTable *i) {return (StgRetInfoTable *)(i + 1) - 1;}
65 INLINE_HEADER StgThunkInfoTable *itbl_to_thunk_itbl(const StgInfoTable *i) {return (StgThunkInfoTable *)(i + 1) - 1;}
66 INLINE_HEADER StgConInfoTable *itbl_to_con_itbl(const StgInfoTable *i) {return (StgConInfoTable *)(i + 1) - 1;}
67 #else
68 EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info);
69 EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgInfoTable *)info;}
70 EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info);
71 EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgRetInfoTable *)info;}
72 INLINE_HEADER StgFunInfoTable *FUN_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgFunInfoTable *)info;}
73 INLINE_HEADER StgThunkInfoTable *THUNK_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgThunkInfoTable *)info;}
74 INLINE_HEADER StgConInfoTable *CON_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgConInfoTable *)info;}
75 INLINE_HEADER StgFunInfoTable *itbl_to_fun_itbl(const StgInfoTable *i) {return (StgFunInfoTable *)i;}
76 INLINE_HEADER StgRetInfoTable *itbl_to_ret_itbl(const StgInfoTable *i) {return (StgRetInfoTable *)i;}
77 INLINE_HEADER StgThunkInfoTable *itbl_to_thunk_itbl(const StgInfoTable *i) {return (StgThunkInfoTable *)i;}
78 INLINE_HEADER StgConInfoTable *itbl_to_con_itbl(const StgInfoTable *i) {return (StgConInfoTable *)i;}
79 #endif
80
81 EXTERN_INLINE StgInfoTable *get_itbl(const StgClosure *c);
82 EXTERN_INLINE StgInfoTable *get_itbl(const StgClosure *c) {return INFO_PTR_TO_STRUCT(c->header.info);}
83
84 EXTERN_INLINE StgRetInfoTable *get_ret_itbl(const StgClosure *c);
85 EXTERN_INLINE StgRetInfoTable *get_ret_itbl(const StgClosure *c) {return RET_INFO_PTR_TO_STRUCT(c->header.info);}
86
87 INLINE_HEADER StgFunInfoTable *get_fun_itbl(const StgClosure *c) {return FUN_INFO_PTR_TO_STRUCT(c->header.info);}
88
89 INLINE_HEADER StgThunkInfoTable *get_thunk_itbl(const StgClosure *c) {return THUNK_INFO_PTR_TO_STRUCT(c->header.info);}
90
91 INLINE_HEADER StgConInfoTable *get_con_itbl(const StgClosure *c) {return CON_INFO_PTR_TO_STRUCT((c)->header.info);}
92
93 /* -----------------------------------------------------------------------------
94 Macros for building closures
95 -------------------------------------------------------------------------- */
96
97 #ifdef PROFILING
98 #ifdef DEBUG_RETAINER
99 /*
100 For the sake of debugging, we take the safest way for the moment. Actually, this
101 is useful to check the sanity of heap before beginning retainer profiling.
102 flip is defined in RetainerProfile.c, and declared as extern in RetainerProfile.h.
103 Note: change those functions building Haskell objects from C datatypes, i.e.,
104 all rts_mk???() functions in RtsAPI.c, as well.
105 */
106 #define SET_PROF_HDR(c,ccs_) \
107 ((c)->header.prof.ccs = ccs_, (c)->header.prof.hp.rs = (retainerSet *)((StgWord)NULL | flip))
108 #else
109 /*
110 For retainer profiling only: we do not have to set (c)->header.prof.hp.rs to
111 NULL | flip (flip is defined in RetainerProfile.c) because even when flip
112 is 1, rs is invalid and will be initialized to NULL | flip later when
113 the closure *c is visited.
114 */
115 /*
116 #define SET_PROF_HDR(c,ccs_) \
117 ((c)->header.prof.ccs = ccs_, (c)->header.prof.hp.rs = NULL)
118 */
119 /*
120 The following macro works for both retainer profiling and LDV profiling:
121 for retainer profiling, ldvTime remains 0, so rs fields are initialized to 0.
122 See the invariants on ldvTime.
123 */
124 #define SET_PROF_HDR(c,ccs_) \
125 ((c)->header.prof.ccs = ccs_, \
126 LDV_RECORD_CREATE((c)))
127 #endif /* DEBUG_RETAINER */
128 #else
129 #define SET_PROF_HDR(c,ccs)
130 #endif
131
132 #define SET_HDR(c,_info,ccs) \
133 { \
134 (c)->header.info = _info; \
135 SET_PROF_HDR((StgClosure *)(c),ccs); \
136 }
137
138 #define SET_ARR_HDR(c,info,costCentreStack,n_bytes) \
139 SET_HDR(c,info,costCentreStack); \
140 (c)->bytes = n_bytes;
141
142 // Use when changing a closure from one kind to another
143 #define OVERWRITE_INFO(c, new_info) \
144 OVERWRITING_CLOSURE((StgClosure *)(c)); \
145 SET_INFO((c), (new_info)); \
146 LDV_RECORD_CREATE(c);
147
148 /* -----------------------------------------------------------------------------
149 How to get hold of the static link field for a static closure.
150 -------------------------------------------------------------------------- */
151
152 /* These are hard-coded. */
153 #define FUN_STATIC_LINK(p) (&(p)->payload[0])
154 #define THUNK_STATIC_LINK(p) (&(p)->payload[1])
155 #define IND_STATIC_LINK(p) (&(p)->payload[1])
156
157 INLINE_HEADER StgClosure **
158 STATIC_LINK(const StgInfoTable *info, StgClosure *p)
159 {
160 switch (info->type) {
161 case THUNK_STATIC:
162 return THUNK_STATIC_LINK(p);
163 case FUN_STATIC:
164 return FUN_STATIC_LINK(p);
165 case IND_STATIC:
166 return IND_STATIC_LINK(p);
167 default:
168 return &(p)->payload[info->layout.payload.ptrs +
169 info->layout.payload.nptrs];
170 }
171 }
172
173 #define STATIC_LINK2(info,p) \
174 (*(StgClosure**)(&((p)->payload[info->layout.payload.ptrs + \
175 info->layout.payload.nptrs + 1])))
176
177 /* -----------------------------------------------------------------------------
178 INTLIKE and CHARLIKE closures.
179 -------------------------------------------------------------------------- */
180
181 #define CHARLIKE_CLOSURE(n) ((P_)&stg_CHARLIKE_closure[(n)-MIN_CHARLIKE])
182 #define INTLIKE_CLOSURE(n) ((P_)&stg_INTLIKE_closure[(n)-MIN_INTLIKE])
183
184 /* ----------------------------------------------------------------------------
185 Macros for untagging and retagging closure pointers
186 For more information look at the comments in Cmm.h
187 ------------------------------------------------------------------------- */
188
189 static inline StgWord
190 GET_CLOSURE_TAG(StgClosure * p)
191 {
192 return (StgWord)p & TAG_MASK;
193 }
194
195 static inline StgClosure *
196 UNTAG_CLOSURE(StgClosure * p)
197 {
198 return (StgClosure*)((StgWord)p & ~TAG_MASK);
199 }
200
201 static inline StgClosure *
202 TAG_CLOSURE(StgWord tag,StgClosure * p)
203 {
204 return (StgClosure*)((StgWord)p | tag);
205 }
206
207 /* -----------------------------------------------------------------------------
208 Forwarding pointers
209 -------------------------------------------------------------------------- */
210
211 #define IS_FORWARDING_PTR(p) ((((StgWord)p) & 1) != 0)
212 #define MK_FORWARDING_PTR(p) (((StgWord)p) | 1)
213 #define UN_FORWARDING_PTR(p) (((StgWord)p) - 1)
214
215 /* -----------------------------------------------------------------------------
216 DEBUGGING predicates for pointers
217
218 LOOKS_LIKE_INFO_PTR(p) returns False if p is definitely not an info ptr
219 LOOKS_LIKE_CLOSURE_PTR(p) returns False if p is definitely not a closure ptr
220
221 These macros are complete but not sound. That is, they might
222 return false positives. Do not rely on them to distinguish info
223 pointers from closure pointers, for example.
224
225 We don't use address-space predicates these days, for portability
226 reasons, and the fact that code/data can be scattered about the
227 address space in a dynamically-linked environment. Our best option
228 is to look at the alleged info table and see whether it seems to
229 make sense...
230 -------------------------------------------------------------------------- */
231
232 INLINE_HEADER rtsBool LOOKS_LIKE_INFO_PTR_NOT_NULL (StgWord p)
233 {
234 StgInfoTable *info = INFO_PTR_TO_STRUCT((StgInfoTable *)p);
235 return info->type != INVALID_OBJECT && info->type < N_CLOSURE_TYPES;
236 }
237
238 INLINE_HEADER rtsBool LOOKS_LIKE_INFO_PTR (StgWord p)
239 {
240 return p && (IS_FORWARDING_PTR(p) || LOOKS_LIKE_INFO_PTR_NOT_NULL(p));
241 }
242
243 INLINE_HEADER rtsBool LOOKS_LIKE_CLOSURE_PTR (void *p)
244 {
245 return LOOKS_LIKE_INFO_PTR((StgWord)(UNTAG_CLOSURE((StgClosure *)(p)))->header.info);
246 }
247
248 /* -----------------------------------------------------------------------------
249 Macros for calculating the size of a closure
250 -------------------------------------------------------------------------- */
251
252 EXTERN_INLINE StgOffset PAP_sizeW ( nat n_args );
253 EXTERN_INLINE StgOffset PAP_sizeW ( nat n_args )
254 { return sizeofW(StgPAP) + n_args; }
255
256 EXTERN_INLINE StgOffset AP_sizeW ( nat n_args );
257 EXTERN_INLINE StgOffset AP_sizeW ( nat n_args )
258 { return sizeofW(StgAP) + n_args; }
259
260 EXTERN_INLINE StgOffset AP_STACK_sizeW ( nat size );
261 EXTERN_INLINE StgOffset AP_STACK_sizeW ( nat size )
262 { return sizeofW(StgAP_STACK) + size; }
263
264 EXTERN_INLINE StgOffset CONSTR_sizeW( nat p, nat np );
265 EXTERN_INLINE StgOffset CONSTR_sizeW( nat p, nat np )
266 { return sizeofW(StgHeader) + p + np; }
267
268 EXTERN_INLINE StgOffset THUNK_SELECTOR_sizeW ( void );
269 EXTERN_INLINE StgOffset THUNK_SELECTOR_sizeW ( void )
270 { return sizeofW(StgSelector); }
271
272 EXTERN_INLINE StgOffset BLACKHOLE_sizeW ( void );
273 EXTERN_INLINE StgOffset BLACKHOLE_sizeW ( void )
274 { return sizeofW(StgInd); } // a BLACKHOLE is a kind of indirection
275
276 /* --------------------------------------------------------------------------
277 Sizes of closures
278 ------------------------------------------------------------------------*/
279
280 EXTERN_INLINE StgOffset sizeW_fromITBL( const StgInfoTable* itbl );
281 EXTERN_INLINE StgOffset sizeW_fromITBL( const StgInfoTable* itbl )
282 { return sizeofW(StgClosure)
283 + sizeofW(StgPtr) * itbl->layout.payload.ptrs
284 + sizeofW(StgWord) * itbl->layout.payload.nptrs; }
285
286 EXTERN_INLINE StgOffset thunk_sizeW_fromITBL( const StgInfoTable* itbl );
287 EXTERN_INLINE StgOffset thunk_sizeW_fromITBL( const StgInfoTable* itbl )
288 { return sizeofW(StgThunk)
289 + sizeofW(StgPtr) * itbl->layout.payload.ptrs
290 + sizeofW(StgWord) * itbl->layout.payload.nptrs; }
291
292 EXTERN_INLINE StgOffset ap_stack_sizeW( StgAP_STACK* x );
293 EXTERN_INLINE StgOffset ap_stack_sizeW( StgAP_STACK* x )
294 { return AP_STACK_sizeW(x->size); }
295
296 EXTERN_INLINE StgOffset ap_sizeW( StgAP* x );
297 EXTERN_INLINE StgOffset ap_sizeW( StgAP* x )
298 { return AP_sizeW(x->n_args); }
299
300 EXTERN_INLINE StgOffset pap_sizeW( StgPAP* x );
301 EXTERN_INLINE StgOffset pap_sizeW( StgPAP* x )
302 { return PAP_sizeW(x->n_args); }
303
304 EXTERN_INLINE StgWord arr_words_words( StgArrWords* x);
305 EXTERN_INLINE StgWord arr_words_words( StgArrWords* x)
306 { return ROUNDUP_BYTES_TO_WDS(x->bytes); }
307
308 EXTERN_INLINE StgOffset arr_words_sizeW( StgArrWords* x );
309 EXTERN_INLINE StgOffset arr_words_sizeW( StgArrWords* x )
310 { return sizeofW(StgArrWords) + arr_words_words(x); }
311
312 EXTERN_INLINE StgOffset mut_arr_ptrs_sizeW( StgMutArrPtrs* x );
313 EXTERN_INLINE StgOffset mut_arr_ptrs_sizeW( StgMutArrPtrs* x )
314 { return sizeofW(StgMutArrPtrs) + x->size; }
315
316 EXTERN_INLINE StgWord stack_sizeW ( StgStack *stack );
317 EXTERN_INLINE StgWord stack_sizeW ( StgStack *stack )
318 { return sizeofW(StgStack) + stack->stack_size; }
319
320 EXTERN_INLINE StgWord bco_sizeW ( StgBCO *bco );
321 EXTERN_INLINE StgWord bco_sizeW ( StgBCO *bco )
322 { return bco->size; }
323
324 EXTERN_INLINE nat closure_sizeW_ (StgClosure *p, StgInfoTable *info);
325 EXTERN_INLINE nat
326 closure_sizeW_ (StgClosure *p, StgInfoTable *info)
327 {
328 switch (info->type) {
329 case THUNK_0_1:
330 case THUNK_1_0:
331 return sizeofW(StgThunk) + 1;
332 case FUN_0_1:
333 case CONSTR_0_1:
334 case FUN_1_0:
335 case CONSTR_1_0:
336 return sizeofW(StgHeader) + 1;
337 case THUNK_0_2:
338 case THUNK_1_1:
339 case THUNK_2_0:
340 return sizeofW(StgThunk) + 2;
341 case FUN_0_2:
342 case CONSTR_0_2:
343 case FUN_1_1:
344 case CONSTR_1_1:
345 case FUN_2_0:
346 case CONSTR_2_0:
347 return sizeofW(StgHeader) + 2;
348 case THUNK:
349 return thunk_sizeW_fromITBL(info);
350 case THUNK_SELECTOR:
351 return THUNK_SELECTOR_sizeW();
352 case AP_STACK:
353 return ap_stack_sizeW((StgAP_STACK *)p);
354 case AP:
355 return ap_sizeW((StgAP *)p);
356 case PAP:
357 return pap_sizeW((StgPAP *)p);
358 case IND:
359 case IND_PERM:
360 return sizeofW(StgInd);
361 case ARR_WORDS:
362 return arr_words_sizeW((StgArrWords *)p);
363 case MUT_ARR_PTRS_CLEAN:
364 case MUT_ARR_PTRS_DIRTY:
365 case MUT_ARR_PTRS_FROZEN:
366 case MUT_ARR_PTRS_FROZEN0:
367 return mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
368 case TSO:
369 return sizeofW(StgTSO);
370 case STACK:
371 return stack_sizeW((StgStack*)p);
372 case BCO:
373 return bco_sizeW((StgBCO *)p);
374 case TREC_CHUNK:
375 return sizeofW(StgTRecChunk);
376 default:
377 return sizeW_fromITBL(info);
378 }
379 }
380
381 // The definitive way to find the size, in words, of a heap-allocated closure
382 EXTERN_INLINE nat closure_sizeW (StgClosure *p);
383 EXTERN_INLINE nat closure_sizeW (StgClosure *p)
384 {
385 return closure_sizeW_(p, get_itbl(p));
386 }
387
388 /* -----------------------------------------------------------------------------
389 Sizes of stack frames
390 -------------------------------------------------------------------------- */
391
392 EXTERN_INLINE StgWord stack_frame_sizeW( StgClosure *frame );
393 EXTERN_INLINE StgWord stack_frame_sizeW( StgClosure *frame )
394 {
395 StgRetInfoTable *info;
396
397 info = get_ret_itbl(frame);
398 switch (info->i.type) {
399
400 case RET_DYN:
401 {
402 StgRetDyn *dyn = (StgRetDyn *)frame;
403 return sizeofW(StgRetDyn) + RET_DYN_BITMAP_SIZE +
404 RET_DYN_NONPTR_REGS_SIZE +
405 RET_DYN_PTRS(dyn->liveness) + RET_DYN_NONPTRS(dyn->liveness);
406 }
407
408 case RET_FUN:
409 return sizeofW(StgRetFun) + ((StgRetFun *)frame)->size;
410
411 case RET_BIG:
412 return 1 + GET_LARGE_BITMAP(&info->i)->size;
413
414 case RET_BCO:
415 return 2 + BCO_BITMAP_SIZE((StgBCO *)((P_)frame)[1]);
416
417 default:
418 return 1 + BITMAP_SIZE(info->i.layout.bitmap);
419 }
420 }
421
422 /* -----------------------------------------------------------------------------
423 StgMutArrPtrs macros
424
425 An StgMutArrPtrs has a card table to indicate which elements are
426 dirty for the generational GC. The card table is an array of
427 bytes, where each byte covers (1 << MUT_ARR_PTRS_CARD_BITS)
428 elements. The card table is directly after the array data itself.
429 -------------------------------------------------------------------------- */
430
431 // The number of card bytes needed
432 INLINE_HEADER W_ mutArrPtrsCards (W_ elems)
433 {
434 return (W_)((elems + (1 << MUT_ARR_PTRS_CARD_BITS) - 1)
435 >> MUT_ARR_PTRS_CARD_BITS);
436 }
437
438 // The number of words in the card table
439 INLINE_HEADER W_ mutArrPtrsCardTableSize (W_ elems)
440 {
441 return ROUNDUP_BYTES_TO_WDS(mutArrPtrsCards(elems));
442 }
443
444 // The address of the card for a particular card number
445 INLINE_HEADER StgWord8 *mutArrPtrsCard (StgMutArrPtrs *a, W_ n)
446 {
447 return ((StgWord8 *)&(a->payload[a->ptrs]) + n);
448 }
449
450 /* -----------------------------------------------------------------------------
451 Replacing a closure with a different one. We must call
452 OVERWRITING_CLOSURE(p) on the old closure that is about to be
453 overwritten.
454
455 In PROFILING mode, LDV profiling requires that we fill the slop
456 with zeroes, and record the old closure as dead (LDV_recordDead()).
457
458 In DEBUG mode, we must overwrite the slop with zeroes, because the
459 sanity checker wants to walk through the heap checking all the
460 pointers.
461
462 In multicore mode, we *cannot* overwrite slop with zeroes, because
463 another thread might be reading it. So,
464
465 LDV PROFILING is not compatible with +RTS -N<n> (for n > 1)
466
467 THREADED_RTS can be used with DEBUG, but full heap sanity
468 checking is disabled except after major GC.
469
470 -------------------------------------------------------------------------- */
471
472 #if defined(PROFILING) || (!defined(THREADED_RTS) && defined(DEBUG))
473 #define OVERWRITING_CLOSURE(c) overwritingClosure(c)
474 #else
475 #define OVERWRITING_CLOSURE(c) /* nothing */
476 #endif
477
478 #ifdef PROFILING
479 void LDV_recordDead (StgClosure *c, nat size);
480 #endif
481
482 EXTERN_INLINE void overwritingClosure (StgClosure *p);
483 EXTERN_INLINE void overwritingClosure (StgClosure *p)
484 {
485 nat size, i;
486
487 #if defined(PROFILING)
488 if (era <= 0) return;
489 #endif
490
491 size = closure_sizeW(p);
492
493 // For LDV profiling, we need to record the closure as dead
494 #if defined(PROFILING)
495 LDV_recordDead((StgClosure *)(p), size);
496 #endif
497
498 for (i = 0; i < size - sizeofW(StgThunkHeader); i++) {
499 ((StgThunk *)(p))->payload[i] = 0;
500 }
501 }
502
503 #endif /* RTS_STORAGE_CLOSUREMACROS_H */