Cleanup sweep and fix a bug in RTS flag processing.
[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 * This function is called eventually on every object destroyed during
23 * a garbage collection, whether it is a major garbage collection or
24 * not. If c is an 'inherently used' closure, nothing happens. If c
25 * is an ordinary closure, LDV_recordDead() is called on c with its
26 * proper size which excludes the profiling header portion in the
27 * closure. Returns the size of the closure, including the profiling
28 * header portion, so that the caller can find the next closure.
29 * ----------------------------------------------------------------------- */
30 STATIC_INLINE nat
31 processHeapClosureForDead( StgClosure *c )
32 {
33 nat size;
34 const StgInfoTable *info;
35
36 info = get_itbl(c);
37
38 info = c->header.info;
39 if (IS_FORWARDING_PTR(info)) {
40 // The size of the evacuated closure is currently stored in
41 // the LDV field. See SET_EVACUAEE_FOR_LDV() in
42 // includes/StgLdvProf.h.
43 return LDVW(c);
44 }
45 info = INFO_PTR_TO_STRUCT(info);
46
47 ASSERT(((LDVW(c) & LDV_CREATE_MASK) >> LDV_SHIFT) <= era &&
48 ((LDVW(c) & LDV_CREATE_MASK) >> LDV_SHIFT) > 0);
49 ASSERT(((LDVW(c) & LDV_STATE_MASK) == LDV_STATE_CREATE) ||
50 (
51 (LDVW(c) & LDV_LAST_MASK) <= era &&
52 (LDVW(c) & LDV_LAST_MASK) > 0
53 ));
54
55
56 size = closure_sizeW(c);
57
58 switch (info->type) {
59 /*
60 'inherently used' cases: do nothing.
61 */
62 case TSO:
63 case STACK:
64 case MVAR_CLEAN:
65 case MVAR_DIRTY:
66 case MUT_ARR_PTRS_CLEAN:
67 case MUT_ARR_PTRS_DIRTY:
68 case MUT_ARR_PTRS_FROZEN:
69 case MUT_ARR_PTRS_FROZEN0:
70 case ARR_WORDS:
71 case WEAK:
72 case MUT_VAR_CLEAN:
73 case MUT_VAR_DIRTY:
74 case BCO:
75 case PRIM:
76 case MUT_PRIM:
77 case TREC_CHUNK:
78 return size;
79
80 /*
81 ordinary cases: call LDV_recordDead().
82 */
83 case THUNK:
84 case THUNK_1_0:
85 case THUNK_0_1:
86 case THUNK_SELECTOR:
87 case THUNK_2_0:
88 case THUNK_1_1:
89 case THUNK_0_2:
90 case AP:
91 case PAP:
92 case AP_STACK:
93 case CONSTR:
94 case CONSTR_1_0:
95 case CONSTR_0_1:
96 case CONSTR_2_0:
97 case CONSTR_1_1:
98 case CONSTR_0_2:
99 case FUN:
100 case FUN_1_0:
101 case FUN_0_1:
102 case FUN_2_0:
103 case FUN_1_1:
104 case FUN_0_2:
105 case BLACKHOLE:
106 case BLOCKING_QUEUE:
107 case IND_PERM:
108 /*
109 'Ingore' cases
110 */
111 // Why can we ignore IND closures? We assume that
112 // any census is preceded by a major garbage collection, which
113 // IND closures cannot survive. Therefore, it is no
114 // use considering IND closures in the meanwhile
115 // because they will perish before the next census at any
116 // rate.
117 case IND:
118 // Found a dead closure: record its size
119 LDV_recordDead(c, size);
120 return size;
121
122 /*
123 Error case
124 */
125 // static objects
126 case IND_STATIC:
127 case CONSTR_STATIC:
128 case FUN_STATIC:
129 case THUNK_STATIC:
130 case CONSTR_NOCAF_STATIC:
131 // stack objects
132 case UPDATE_FRAME:
133 case CATCH_FRAME:
134 case UNDERFLOW_FRAME:
135 case STOP_FRAME:
136 case RET_DYN:
137 case RET_BCO:
138 case RET_SMALL:
139 case RET_BIG:
140 // others
141 case INVALID_OBJECT:
142 default:
143 barf("Invalid object in processHeapClosureForDead(): %d", info->type);
144 return 0;
145 }
146 }
147
148 /* --------------------------------------------------------------------------
149 * Calls processHeapClosureForDead() on every *dead* closures in the
150 * heap blocks starting at bd.
151 * ----------------------------------------------------------------------- */
152 static void
153 processHeapForDead( bdescr *bd )
154 {
155 StgPtr p;
156
157 while (bd != NULL) {
158 p = bd->start;
159 while (p < bd->free) {
160 p += processHeapClosureForDead((StgClosure *)p);
161 while (p < bd->free && !*p) // skip slop
162 p++;
163 }
164 ASSERT(p == bd->free);
165 bd = bd->link;
166 }
167 }
168
169 /* --------------------------------------------------------------------------
170 * Calls processHeapClosureForDead() on every *dead* closures in the nursery.
171 * ----------------------------------------------------------------------- */
172 static void
173 processNurseryForDead( void )
174 {
175 StgPtr p, bdLimit;
176 bdescr *bd;
177
178 bd = MainCapability.r.rNursery->blocks;
179 while (bd->start < bd->free) {
180 p = bd->start;
181 bdLimit = bd->start + BLOCK_SIZE_W;
182 while (p < bd->free && p < bdLimit) {
183 p += processHeapClosureForDead((StgClosure *)p);
184 while (p < bd->free && p < bdLimit && !*p) // skip slop
185 p++;
186 }
187 bd = bd->link;
188 if (bd == NULL)
189 break;
190 }
191 }
192
193 /* --------------------------------------------------------------------------
194 * Calls processHeapClosureForDead() on every *dead* closures in the closure
195 * chain.
196 * ----------------------------------------------------------------------- */
197 static void
198 processChainForDead( bdescr *bd )
199 {
200 // Any object still in the chain is dead!
201 while (bd != NULL) {
202 if (!(bd->flags & BF_PINNED)) {
203 processHeapClosureForDead((StgClosure *)bd->start);
204 }
205 bd = bd->link;
206 }
207 }
208
209 /* --------------------------------------------------------------------------
210 * Start a census for *dead* closures, and calls
211 * processHeapClosureForDead() on every closure which died in the
212 * current garbage collection. This function is called from a garbage
213 * collector right before tidying up, when all dead closures are still
214 * stored in the heap and easy to identify. Generations 0 through N
215 * have just beed garbage collected.
216 * ----------------------------------------------------------------------- */
217 void
218 LdvCensusForDead( nat N )
219 {
220 nat g;
221
222 // ldvTime == 0 means that LDV profiling is currently turned off.
223 if (era == 0)
224 return;
225
226 if (RtsFlags.GcFlags.generations == 1) {
227 //
228 // Todo: support LDV for two-space garbage collection.
229 //
230 barf("Lag/Drag/Void profiling not supported with -G1");
231 } else {
232 processNurseryForDead();
233 for (g = 0; g <= N; g++) {
234 processHeapForDead(generations[g].old_blocks);
235 processChainForDead(generations[g].large_objects);
236 }
237 }
238 }
239
240 /* --------------------------------------------------------------------------
241 * Regard any closure in the current heap as dead or moribund and update
242 * LDV statistics accordingly.
243 * Called from shutdownHaskell() in RtsStartup.c.
244 * Also, stops LDV profiling by resetting ldvTime to 0.
245 * ----------------------------------------------------------------------- */
246 void
247 LdvCensusKillAll( void )
248 {
249 LdvCensusForDead(RtsFlags.GcFlags.generations - 1);
250 }
251
252 #endif /* PROFILING */