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