STM invariants
[ghc.git] / rts / LdvProfile.c
1 /* -----------------------------------------------------------------------------
2 *
3 * (c) The GHC Team, 2001
4 * Author: Sungwoo Park
5 *
6 * Lag/Drag/Void profiling.
7 *
8 * ---------------------------------------------------------------------------*/
9
10 #ifdef PROFILING
11
12 #include "Rts.h"
13 #include "LdvProfile.h"
14 #include "RtsFlags.h"
15 #include "Profiling.h"
16 #include "Stats.h"
17 #include "Storage.h"
18 #include "RtsUtils.h"
19 #include "Schedule.h"
20
21 /* --------------------------------------------------------------------------
22 * Fills in the slop when a *dynamic* closure changes its type.
23 * First calls LDV_recordDead() to declare the closure is dead, and then
24 * fills in the slop.
25 *
26 * Invoked when:
27 * 1) blackholing, UPD_BH_UPDATABLE() and UPD_BH_SINGLE_ENTRY (in
28 * includes/StgMacros.h), threadLazyBlackHole() and
29 * threadSqueezeStack() (in GC.c).
30 * 2) updating with indirection closures, updateWithIndirection()
31 * and updateWithPermIndirection() (in Storage.h).
32 *
33 * LDV_recordDead_FILL_SLOP_DYNAMIC() is not called on 'inherently used'
34 * closures such as TSO. It is not called on PAP because PAP is not updatable.
35 * ----------------------------------------------------------------------- */
36 void
37 LDV_recordDead_FILL_SLOP_DYNAMIC( StgClosure *p )
38 {
39 nat size, i;
40
41 #if defined(__GNUC__) && __GNUC__ < 3 && defined(DEBUG)
42 #error Please use gcc 3.0+ to compile this file with DEBUG; gcc < 3.0 miscompiles it
43 #endif
44
45 if (era > 0) {
46 // very like FILL_SLOP(), except that we call LDV_recordDead().
47 size = closure_sizeW(p);
48
49 LDV_recordDead((StgClosure *)(p), size);
50
51 if (size > sizeofW(StgThunkHeader)) {
52 for (i = 0; i < size - sizeofW(StgThunkHeader); i++) {
53 ((StgThunk *)(p))->payload[i] = 0;
54 }
55 }
56 }
57 }
58
59 /* --------------------------------------------------------------------------
60 * This function is called eventually on every object destroyed during
61 * a garbage collection, whether it is a major garbage collection or
62 * not. If c is an 'inherently used' closure, nothing happens. If c
63 * is an ordinary closure, LDV_recordDead() is called on c with its
64 * proper size which excludes the profiling header portion in the
65 * closure. Returns the size of the closure, including the profiling
66 * header portion, so that the caller can find the next closure.
67 * ----------------------------------------------------------------------- */
68 STATIC_INLINE nat
69 processHeapClosureForDead( StgClosure *c )
70 {
71 nat size;
72 StgInfoTable *info;
73
74 info = get_itbl(c);
75
76 if (info->type != EVACUATED) {
77 ASSERT(((LDVW(c) & LDV_CREATE_MASK) >> LDV_SHIFT) <= era &&
78 ((LDVW(c) & LDV_CREATE_MASK) >> LDV_SHIFT) > 0);
79 ASSERT(((LDVW(c) & LDV_STATE_MASK) == LDV_STATE_CREATE) ||
80 (
81 (LDVW(c) & LDV_LAST_MASK) <= era &&
82 (LDVW(c) & LDV_LAST_MASK) > 0
83 ));
84 }
85
86 if (info->type == EVACUATED) {
87 // The size of the evacuated closure is currently stored in
88 // the LDV field. See SET_EVACUAEE_FOR_LDV() in
89 // includes/StgLdvProf.h.
90 return LDVW(c);
91 }
92
93 size = closure_sizeW(c);
94
95 switch (info->type) {
96 /*
97 'inherently used' cases: do nothing.
98 */
99 case TSO:
100 case MVAR:
101 case MUT_ARR_PTRS_CLEAN:
102 case MUT_ARR_PTRS_DIRTY:
103 case MUT_ARR_PTRS_FROZEN:
104 case MUT_ARR_PTRS_FROZEN0:
105 case ARR_WORDS:
106 case WEAK:
107 case MUT_VAR_CLEAN:
108 case MUT_VAR_DIRTY:
109 case BCO:
110 case STABLE_NAME:
111 case TVAR_WATCH_QUEUE:
112 case TVAR:
113 case TREC_HEADER:
114 case TREC_CHUNK:
115 case INVARIANT_CHECK_QUEUE:
116 case ATOMIC_INVARIANT:
117 return size;
118
119 /*
120 ordinary cases: call LDV_recordDead().
121 */
122 case THUNK:
123 case THUNK_1_0:
124 case THUNK_0_1:
125 case THUNK_SELECTOR:
126 case THUNK_2_0:
127 case THUNK_1_1:
128 case THUNK_0_2:
129 case AP:
130 case PAP:
131 case AP_STACK:
132 case CONSTR:
133 case CONSTR_1_0:
134 case CONSTR_0_1:
135 case CONSTR_2_0:
136 case CONSTR_1_1:
137 case CONSTR_0_2:
138 case FUN:
139 case FUN_1_0:
140 case FUN_0_1:
141 case FUN_2_0:
142 case FUN_1_1:
143 case FUN_0_2:
144 case BLACKHOLE:
145 case SE_BLACKHOLE:
146 case CAF_BLACKHOLE:
147 case SE_CAF_BLACKHOLE:
148 case IND_PERM:
149 case IND_OLDGEN_PERM:
150 /*
151 'Ingore' cases
152 */
153 // Why can we ignore IND/IND_OLDGEN closures? We assume that
154 // any census is preceded by a major garbage collection, which
155 // IND/IND_OLDGEN closures cannot survive. Therefore, it is no
156 // use considering IND/IND_OLDGEN closures in the meanwhile
157 // because they will perish before the next census at any
158 // rate.
159 case IND:
160 case IND_OLDGEN:
161 // Found a dead closure: record its size
162 LDV_recordDead(c, size);
163 return size;
164
165 /*
166 Error case
167 */
168 // static objects
169 case IND_STATIC:
170 case CONSTR_STATIC:
171 case FUN_STATIC:
172 case THUNK_STATIC:
173 case CONSTR_NOCAF_STATIC:
174 // stack objects
175 case UPDATE_FRAME:
176 case CATCH_FRAME:
177 case STOP_FRAME:
178 case RET_DYN:
179 case RET_BCO:
180 case RET_SMALL:
181 case RET_VEC_SMALL:
182 case RET_BIG:
183 case RET_VEC_BIG:
184 // others
185 case BLOCKED_FETCH:
186 case FETCH_ME:
187 case FETCH_ME_BQ:
188 case RBH:
189 case REMOTE_REF:
190 case INVALID_OBJECT:
191 default:
192 barf("Invalid object in processHeapClosureForDead(): %d", info->type);
193 return 0;
194 }
195 }
196
197 /* --------------------------------------------------------------------------
198 * Calls processHeapClosureForDead() on every *dead* closures in the
199 * heap blocks starting at bd.
200 * ----------------------------------------------------------------------- */
201 static void
202 processHeapForDead( bdescr *bd )
203 {
204 StgPtr p;
205
206 while (bd != NULL) {
207 p = bd->start;
208 while (p < bd->free) {
209 p += processHeapClosureForDead((StgClosure *)p);
210 while (p < bd->free && !*p) // skip slop
211 p++;
212 }
213 ASSERT(p == bd->free);
214 bd = bd->link;
215 }
216 }
217
218 /* --------------------------------------------------------------------------
219 * Calls processHeapClosureForDead() on every *dead* closures in the nursery.
220 * ----------------------------------------------------------------------- */
221 static void
222 processNurseryForDead( void )
223 {
224 StgPtr p, bdLimit;
225 bdescr *bd;
226
227 bd = MainCapability.r.rNursery->blocks;
228 while (bd->start < bd->free) {
229 p = bd->start;
230 bdLimit = bd->start + BLOCK_SIZE_W;
231 while (p < bd->free && p < bdLimit) {
232 p += processHeapClosureForDead((StgClosure *)p);
233 while (p < bd->free && p < bdLimit && !*p) // skip slop
234 p++;
235 }
236 bd = bd->link;
237 if (bd == NULL)
238 break;
239 }
240 }
241
242 /* --------------------------------------------------------------------------
243 * Calls processHeapClosureForDead() on every *dead* closures in the
244 * small object pool.
245 * ----------------------------------------------------------------------- */
246 static void
247 processSmallObjectPoolForDead( void )
248 {
249 bdescr *bd;
250 StgPtr p;
251
252 bd = small_alloc_list;
253
254 // first block
255 if (bd == NULL)
256 return;
257
258 p = bd->start;
259 while (p < alloc_Hp) {
260 p += processHeapClosureForDead((StgClosure *)p);
261 while (p < alloc_Hp && !*p) // skip slop
262 p++;
263 }
264 ASSERT(p == alloc_Hp);
265
266 bd = bd->link;
267 while (bd != NULL) {
268 p = bd->start;
269 while (p < bd->free) {
270 p += processHeapClosureForDead((StgClosure *)p);
271 while (p < bd->free && !*p) // skip slop
272 p++;
273 }
274 ASSERT(p == bd->free);
275 bd = bd->link;
276 }
277 }
278
279 /* --------------------------------------------------------------------------
280 * Calls processHeapClosureForDead() on every *dead* closures in the closure
281 * chain.
282 * ----------------------------------------------------------------------- */
283 static void
284 processChainForDead( bdescr *bd )
285 {
286 // Any object still in the chain is dead!
287 while (bd != NULL) {
288 processHeapClosureForDead((StgClosure *)bd->start);
289 bd = bd->link;
290 }
291 }
292
293 /* --------------------------------------------------------------------------
294 * Start a census for *dead* closures, and calls
295 * processHeapClosureForDead() on every closure which died in the
296 * current garbage collection. This function is called from a garbage
297 * collector right before tidying up, when all dead closures are still
298 * stored in the heap and easy to identify. Generations 0 through N
299 * have just beed garbage collected.
300 * ----------------------------------------------------------------------- */
301 void
302 LdvCensusForDead( nat N )
303 {
304 nat g, s;
305
306 // ldvTime == 0 means that LDV profiling is currently turned off.
307 if (era == 0)
308 return;
309
310 if (RtsFlags.GcFlags.generations == 1) {
311 //
312 // Todo: support LDV for two-space garbage collection.
313 //
314 barf("Lag/Drag/Void profiling not supported with -G1");
315 } else {
316 for (g = 0; g <= N; g++)
317 for (s = 0; s < generations[g].n_steps; s++) {
318 if (g == 0 && s == 0) {
319 processSmallObjectPoolForDead();
320 processNurseryForDead();
321 processChainForDead(generations[g].steps[s].large_objects);
322 } else{
323 processHeapForDead(generations[g].steps[s].old_blocks);
324 processChainForDead(generations[g].steps[s].large_objects);
325 }
326 }
327 }
328 }
329
330 /* --------------------------------------------------------------------------
331 * Regard any closure in the current heap as dead or moribund and update
332 * LDV statistics accordingly.
333 * Called from shutdownHaskell() in RtsStartup.c.
334 * Also, stops LDV profiling by resetting ldvTime to 0.
335 * ----------------------------------------------------------------------- */
336 void
337 LdvCensusKillAll( void )
338 {
339 LdvCensusForDead(RtsFlags.GcFlags.generations - 1);
340 }
341
342 #endif /* PROFILING */