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