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