hadrian: eliminate most of the remaining big rule enumerations
[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 #if defined(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 uint32_t
31 processHeapClosureForDead( const StgClosure *c )
32 {
33 uint32_t 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 TVAR:
67 case MUT_ARR_PTRS_CLEAN:
68 case MUT_ARR_PTRS_DIRTY:
69 case MUT_ARR_PTRS_FROZEN_CLEAN:
70 case MUT_ARR_PTRS_FROZEN_DIRTY:
71 case SMALL_MUT_ARR_PTRS_CLEAN:
72 case SMALL_MUT_ARR_PTRS_DIRTY:
73 case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
74 case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
75 case ARR_WORDS:
76 case WEAK:
77 case MUT_VAR_CLEAN:
78 case MUT_VAR_DIRTY:
79 case BCO:
80 case PRIM:
81 case MUT_PRIM:
82 case TREC_CHUNK:
83 return size;
84
85 /*
86 ordinary cases: call LDV_recordDead().
87 */
88 case THUNK:
89 case THUNK_1_0:
90 case THUNK_0_1:
91 case THUNK_SELECTOR:
92 case THUNK_2_0:
93 case THUNK_1_1:
94 case THUNK_0_2:
95 case AP:
96 case PAP:
97 case AP_STACK:
98 case CONSTR:
99 case CONSTR_1_0:
100 case CONSTR_0_1:
101 case CONSTR_2_0:
102 case CONSTR_1_1:
103 case CONSTR_0_2:
104 case CONSTR_NOCAF:
105 case FUN:
106 case FUN_1_0:
107 case FUN_0_1:
108 case FUN_2_0:
109 case FUN_1_1:
110 case FUN_0_2:
111 case BLACKHOLE:
112 case BLOCKING_QUEUE:
113 /*
114 'Ingore' cases
115 */
116 // Why can we ignore IND closures? We assume that
117 // any census is preceded by a major garbage collection, which
118 // IND closures cannot survive. Therefore, it is no
119 // use considering IND closures in the meanwhile
120 // because they will perish before the next census at any
121 // rate.
122 case IND:
123 // Found a dead closure: record its size
124 LDV_recordDead(c, size);
125 return size;
126
127 /*
128 Error case
129 */
130 // static objects
131 case IND_STATIC:
132 case FUN_STATIC:
133 case THUNK_STATIC:
134 // stack objects
135 case UPDATE_FRAME:
136 case CATCH_FRAME:
137 case UNDERFLOW_FRAME:
138 case STOP_FRAME:
139 case RET_BCO:
140 case RET_SMALL:
141 case RET_BIG:
142 case CATCH_STM_FRAME:
143 case CATCH_RETRY_FRAME:
144 case ATOMICALLY_FRAME:
145 // others
146 case INVALID_OBJECT:
147 case COMPACT_NFDATA:
148 default:
149 barf("Invalid object in processHeapClosureForDead(): %d", info->type);
150 return 0;
151 }
152 }
153
154 /* --------------------------------------------------------------------------
155 * Calls processHeapClosureForDead() on every *dead* closures in the
156 * heap blocks starting at bd.
157 * ----------------------------------------------------------------------- */
158 static void
159 processHeapForDead( bdescr *bd )
160 {
161 StgPtr p;
162
163 while (bd != NULL) {
164 p = bd->start;
165 while (p < bd->free) {
166 p += processHeapClosureForDead((StgClosure *)p);
167 while (p < bd->free && !*p) // skip slop
168 p++;
169 }
170 ASSERT(p == bd->free);
171 bd = bd->link;
172 }
173 }
174
175 /* --------------------------------------------------------------------------
176 * Calls processHeapClosureForDead() on every *dead* closures in the nursery.
177 * ----------------------------------------------------------------------- */
178 static void
179 processNurseryForDead( void )
180 {
181 StgPtr p;
182 bdescr *bd;
183
184 if (MainCapability.r.rNursery == NULL)
185 return;
186
187 for (bd = MainCapability.r.rNursery->blocks; bd != NULL; bd = bd->link) {
188 p = bd->start;
189 while (p < bd->free) {
190 while (p < bd->free && !*p) p++; // skip slop
191 if (p >= bd->free) break;
192 p += processHeapClosureForDead((StgClosure *)p);
193 }
194 }
195 }
196
197 /* --------------------------------------------------------------------------
198 * Calls processHeapClosureForDead() on every *dead* closures in the closure
199 * chain.
200 * ----------------------------------------------------------------------- */
201 static void
202 processChainForDead( bdescr *bd )
203 {
204 // Any object still in the chain is dead!
205 while (bd != NULL) {
206 if (!(bd->flags & BF_PINNED)) {
207 processHeapClosureForDead((StgClosure *)bd->start);
208 }
209 bd = bd->link;
210 }
211 }
212
213 /* --------------------------------------------------------------------------
214 * Start a census for *dead* closures, and calls
215 * processHeapClosureForDead() on every closure which died in the
216 * current garbage collection. This function is called from a garbage
217 * collector right before tidying up, when all dead closures are still
218 * stored in the heap and easy to identify. Generations 0 through N
219 * have just been garbage collected.
220 * ----------------------------------------------------------------------- */
221 void
222 LdvCensusForDead( uint32_t N )
223 {
224 uint32_t g;
225
226 // ldvTime == 0 means that LDV profiling is currently turned off.
227 if (era == 0)
228 return;
229
230 if (RtsFlags.GcFlags.generations == 1) {
231 //
232 // Todo: support LDV for two-space garbage collection.
233 //
234 barf("Lag/Drag/Void profiling not supported with -G1");
235 } else {
236 processNurseryForDead();
237 for (g = 0; g <= N; g++) {
238 processHeapForDead(generations[g].old_blocks);
239 processChainForDead(generations[g].large_objects);
240 }
241 }
242 }
243
244 /* --------------------------------------------------------------------------
245 * Regard any closure in the current heap as dead or moribund and update
246 * LDV statistics accordingly.
247 * Called from shutdownHaskell() in RtsStartup.c.
248 * Also, stops LDV profiling by resetting ldvTime to 0.
249 * ----------------------------------------------------------------------- */
250 void
251 LdvCensusKillAll( void )
252 {
253 LdvCensusForDead(RtsFlags.GcFlags.generations - 1);
254 }
255
256 #endif /* PROFILING */