add a missing STACK case
[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 "PosixSource.h"
13 #include "Rts.h"
14
15 #include "Profiling.h"
16 #include "LdvProfile.h"
17 #include "Stats.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 const StgInfoTable *info;
73
74 info = get_itbl(c);
75
76 info = c->header.info;
77 if (IS_FORWARDING_PTR(info)) {
78 // The size of the evacuated closure is currently stored in
79 // the LDV field. See SET_EVACUAEE_FOR_LDV() in
80 // includes/StgLdvProf.h.
81 return LDVW(c);
82 }
83 info = INFO_PTR_TO_STRUCT(info);
84
85 ASSERT(((LDVW(c) & LDV_CREATE_MASK) >> LDV_SHIFT) <= era &&
86 ((LDVW(c) & LDV_CREATE_MASK) >> LDV_SHIFT) > 0);
87 ASSERT(((LDVW(c) & LDV_STATE_MASK) == LDV_STATE_CREATE) ||
88 (
89 (LDVW(c) & LDV_LAST_MASK) <= era &&
90 (LDVW(c) & LDV_LAST_MASK) > 0
91 ));
92
93
94 size = closure_sizeW(c);
95
96 switch (info->type) {
97 /*
98 'inherently used' cases: do nothing.
99 */
100 case TSO:
101 case STACK:
102 case MVAR_CLEAN:
103 case MVAR_DIRTY:
104 case MUT_ARR_PTRS_CLEAN:
105 case MUT_ARR_PTRS_DIRTY:
106 case MUT_ARR_PTRS_FROZEN:
107 case MUT_ARR_PTRS_FROZEN0:
108 case ARR_WORDS:
109 case WEAK:
110 case MUT_VAR_CLEAN:
111 case MUT_VAR_DIRTY:
112 case BCO:
113 case PRIM:
114 case MUT_PRIM:
115 case TREC_CHUNK:
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 BLOCKING_QUEUE:
145 case IND_PERM:
146 /*
147 'Ingore' cases
148 */
149 // Why can we ignore IND closures? We assume that
150 // any census is preceded by a major garbage collection, which
151 // IND closures cannot survive. Therefore, it is no
152 // use considering IND closures in the meanwhile
153 // because they will perish before the next census at any
154 // rate.
155 case IND:
156 // Found a dead closure: record its size
157 LDV_recordDead(c, size);
158 return size;
159
160 /*
161 Error case
162 */
163 // static objects
164 case IND_STATIC:
165 case CONSTR_STATIC:
166 case FUN_STATIC:
167 case THUNK_STATIC:
168 case CONSTR_NOCAF_STATIC:
169 // stack objects
170 case UPDATE_FRAME:
171 case CATCH_FRAME:
172 case UNDERFLOW_FRAME:
173 case STOP_FRAME:
174 case RET_DYN:
175 case RET_BCO:
176 case RET_SMALL:
177 case RET_BIG:
178 // others
179 case INVALID_OBJECT:
180 default:
181 barf("Invalid object in processHeapClosureForDead(): %d", info->type);
182 return 0;
183 }
184 }
185
186 /* --------------------------------------------------------------------------
187 * Calls processHeapClosureForDead() on every *dead* closures in the
188 * heap blocks starting at bd.
189 * ----------------------------------------------------------------------- */
190 static void
191 processHeapForDead( bdescr *bd )
192 {
193 StgPtr p;
194
195 while (bd != NULL) {
196 p = bd->start;
197 while (p < bd->free) {
198 p += processHeapClosureForDead((StgClosure *)p);
199 while (p < bd->free && !*p) // skip slop
200 p++;
201 }
202 ASSERT(p == bd->free);
203 bd = bd->link;
204 }
205 }
206
207 /* --------------------------------------------------------------------------
208 * Calls processHeapClosureForDead() on every *dead* closures in the nursery.
209 * ----------------------------------------------------------------------- */
210 static void
211 processNurseryForDead( void )
212 {
213 StgPtr p, bdLimit;
214 bdescr *bd;
215
216 bd = MainCapability.r.rNursery->blocks;
217 while (bd->start < bd->free) {
218 p = bd->start;
219 bdLimit = bd->start + BLOCK_SIZE_W;
220 while (p < bd->free && p < bdLimit) {
221 p += processHeapClosureForDead((StgClosure *)p);
222 while (p < bd->free && p < bdLimit && !*p) // skip slop
223 p++;
224 }
225 bd = bd->link;
226 if (bd == NULL)
227 break;
228 }
229 }
230
231 /* --------------------------------------------------------------------------
232 * Calls processHeapClosureForDead() on every *dead* closures in the closure
233 * chain.
234 * ----------------------------------------------------------------------- */
235 static void
236 processChainForDead( bdescr *bd )
237 {
238 // Any object still in the chain is dead!
239 while (bd != NULL) {
240 if (!(bd->flags & BF_PINNED)) {
241 processHeapClosureForDead((StgClosure *)bd->start);
242 }
243 bd = bd->link;
244 }
245 }
246
247 /* --------------------------------------------------------------------------
248 * Start a census for *dead* closures, and calls
249 * processHeapClosureForDead() on every closure which died in the
250 * current garbage collection. This function is called from a garbage
251 * collector right before tidying up, when all dead closures are still
252 * stored in the heap and easy to identify. Generations 0 through N
253 * have just beed garbage collected.
254 * ----------------------------------------------------------------------- */
255 void
256 LdvCensusForDead( nat N )
257 {
258 nat g;
259
260 // ldvTime == 0 means that LDV profiling is currently turned off.
261 if (era == 0)
262 return;
263
264 if (RtsFlags.GcFlags.generations == 1) {
265 //
266 // Todo: support LDV for two-space garbage collection.
267 //
268 barf("Lag/Drag/Void profiling not supported with -G1");
269 } else {
270 processNurseryForDead();
271 for (g = 0; g <= N; g++) {
272 processHeapForDead(generations[g].old_blocks);
273 processChainForDead(generations[g].large_objects);
274 }
275 }
276 }
277
278 /* --------------------------------------------------------------------------
279 * Regard any closure in the current heap as dead or moribund and update
280 * LDV statistics accordingly.
281 * Called from shutdownHaskell() in RtsStartup.c.
282 * Also, stops LDV profiling by resetting ldvTime to 0.
283 * ----------------------------------------------------------------------- */
284 void
285 LdvCensusKillAll( void )
286 {
287 LdvCensusForDead(RtsFlags.GcFlags.generations - 1);
288 }
289
290 #endif /* PROFILING */