Store a destination step in the block descriptor
[ghc.git] / rts / sm / GCUtils.c
1 /* -----------------------------------------------------------------------------
2 *
3 * (c) The GHC Team 1998-2008
4 *
5 * Generational garbage collector: utilities
6 *
7 * Documentation on the architecture of the Garbage Collector can be
8 * found in the online commentary:
9 *
10 * http://hackage.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/GC
11 *
12 * ---------------------------------------------------------------------------*/
13
14 #include "PosixSource.h"
15 #include "Rts.h"
16
17 #include "Storage.h"
18 #include "GC.h"
19 #include "GCThread.h"
20 #include "GCUtils.h"
21 #include "Printer.h"
22 #include "Trace.h"
23 #ifdef THREADED_RTS
24 #include "WSDeque.h"
25 #endif
26
27 #ifdef THREADED_RTS
28 SpinLock gc_alloc_block_sync;
29 #endif
30
31 bdescr *
32 allocBlock_sync(void)
33 {
34 bdescr *bd;
35 ACQUIRE_SPIN_LOCK(&gc_alloc_block_sync);
36 bd = allocBlock();
37 RELEASE_SPIN_LOCK(&gc_alloc_block_sync);
38 return bd;
39 }
40
41 static bdescr *
42 allocGroup_sync(nat n)
43 {
44 bdescr *bd;
45 ACQUIRE_SPIN_LOCK(&gc_alloc_block_sync);
46 bd = allocGroup(n);
47 RELEASE_SPIN_LOCK(&gc_alloc_block_sync);
48 return bd;
49 }
50
51
52 #if 0
53 static void
54 allocBlocks_sync(nat n, bdescr **hd, bdescr **tl,
55 nat gen_no, step *stp,
56 StgWord32 flags)
57 {
58 bdescr *bd;
59 nat i;
60 ACQUIRE_SPIN_LOCK(&gc_alloc_block_sync);
61 bd = allocGroup(n);
62 for (i = 0; i < n; i++) {
63 bd[i].blocks = 1;
64 bd[i].gen_no = gen_no;
65 bd[i].step = stp;
66 bd[i].flags = flags;
67 bd[i].link = &bd[i+1];
68 bd[i].u.scan = bd[i].free = bd[i].start;
69 }
70 *hd = bd;
71 *tl = &bd[n-1];
72 RELEASE_SPIN_LOCK(&gc_alloc_block_sync);
73 }
74 #endif
75
76 void
77 freeChain_sync(bdescr *bd)
78 {
79 ACQUIRE_SPIN_LOCK(&gc_alloc_block_sync);
80 freeChain(bd);
81 RELEASE_SPIN_LOCK(&gc_alloc_block_sync);
82 }
83
84 /* -----------------------------------------------------------------------------
85 Workspace utilities
86 -------------------------------------------------------------------------- */
87
88 bdescr *
89 grab_local_todo_block (step_workspace *ws)
90 {
91 bdescr *bd;
92 step *stp;
93
94 stp = ws->step;
95
96 bd = ws->todo_overflow;
97 if (bd != NULL)
98 {
99 ws->todo_overflow = bd->link;
100 bd->link = NULL;
101 ws->n_todo_overflow--;
102 return bd;
103 }
104
105 bd = popWSDeque(ws->todo_q);
106 if (bd != NULL)
107 {
108 ASSERT(bd->link == NULL);
109 return bd;
110 }
111
112 return NULL;
113 }
114
115 #if defined(THREADED_RTS)
116 bdescr *
117 steal_todo_block (nat s)
118 {
119 nat n;
120 bdescr *bd;
121
122 // look for work to steal
123 for (n = 0; n < n_gc_threads; n++) {
124 if (n == gct->thread_index) continue;
125 bd = stealWSDeque(gc_threads[n]->steps[s].todo_q);
126 if (bd) {
127 return bd;
128 }
129 }
130 return NULL;
131 }
132 #endif
133
134 void
135 push_scanned_block (bdescr *bd, step_workspace *ws)
136 {
137 ASSERT(bd != NULL);
138 ASSERT(bd->link == NULL);
139 ASSERT(bd->step == ws->step);
140 ASSERT(bd->u.scan == bd->free);
141
142 if (bd->start + bd->blocks * BLOCK_SIZE_W - bd->free > WORK_UNIT_WORDS)
143 {
144 // a partially full block: put it on the part_list list.
145 bd->link = ws->part_list;
146 ws->part_list = bd;
147 ws->n_part_blocks += bd->blocks;
148 IF_DEBUG(sanity,
149 ASSERT(countBlocks(ws->part_list) == ws->n_part_blocks));
150 }
151 else
152 {
153 // put the scan block on the ws->scavd_list.
154 bd->link = ws->scavd_list;
155 ws->scavd_list = bd;
156 ws->n_scavd_blocks += bd->blocks;
157 IF_DEBUG(sanity,
158 ASSERT(countBlocks(ws->scavd_list) == ws->n_scavd_blocks));
159 }
160 }
161
162 StgPtr
163 todo_block_full (nat size, step_workspace *ws)
164 {
165 StgPtr p;
166 bdescr *bd;
167
168 // todo_free has been pre-incremented by Evac.c:alloc_for_copy(). We
169 // are expected to leave it bumped when we've finished here.
170 ws->todo_free -= size;
171
172 bd = ws->todo_bd;
173
174 ASSERT(bd != NULL);
175 ASSERT(bd->link == NULL);
176 ASSERT(bd->step == ws->step);
177
178 // If the global list is not empty, or there's not much work in
179 // this block to push, and there's enough room in
180 // this block to evacuate the current object, then just increase
181 // the limit.
182 if (!looksEmptyWSDeque(ws->todo_q) ||
183 (ws->todo_free - bd->u.scan < WORK_UNIT_WORDS / 2)) {
184 if (ws->todo_free + size < bd->start + bd->blocks * BLOCK_SIZE_W) {
185 ws->todo_lim = stg_min(bd->start + bd->blocks * BLOCK_SIZE_W,
186 ws->todo_lim + stg_max(WORK_UNIT_WORDS,size));
187 debugTrace(DEBUG_gc, "increasing limit for %p to %p", bd->start, ws->todo_lim);
188 p = ws->todo_free;
189 ws->todo_free += size;
190 return p;
191 }
192 }
193
194 gct->copied += ws->todo_free - bd->free;
195 bd->free = ws->todo_free;
196
197 ASSERT(bd->u.scan >= bd->start && bd->u.scan <= bd->free);
198
199 // If this block is not the scan block, we want to push it out and
200 // make room for a new todo block.
201 if (bd != gct->scan_bd)
202 {
203 // If this block does not have enough space to allocate the
204 // current object, but it also doesn't have any work to push, then
205 // push it on to the scanned list. It cannot be empty, because
206 // then there would be enough room to copy the current object.
207 if (bd->u.scan == bd->free)
208 {
209 ASSERT(bd->free != bd->start);
210 push_scanned_block(bd, ws);
211 }
212 // Otherwise, push this block out to the global list.
213 else
214 {
215 step *stp;
216 stp = ws->step;
217 debugTrace(DEBUG_gc, "push todo block %p (%ld words), step %d, todo_q: %ld",
218 bd->start, (unsigned long)(bd->free - bd->u.scan),
219 stp->abs_no, dequeElements(ws->todo_q));
220
221 if (!pushWSDeque(ws->todo_q, bd)) {
222 bd->link = ws->todo_overflow;
223 ws->todo_overflow = bd;
224 ws->n_todo_overflow++;
225 }
226 }
227 }
228
229 ws->todo_bd = NULL;
230 ws->todo_free = NULL;
231 ws->todo_lim = NULL;
232
233 alloc_todo_block(ws, size);
234
235 p = ws->todo_free;
236 ws->todo_free += size;
237 return p;
238 }
239
240 StgPtr
241 alloc_todo_block (step_workspace *ws, nat size)
242 {
243 bdescr *bd/*, *hd, *tl */;
244
245 // Grab a part block if we have one, and it has enough room
246 bd = ws->part_list;
247 if (bd != NULL &&
248 bd->start + bd->blocks * BLOCK_SIZE_W - bd->free > (int)size)
249 {
250 ws->part_list = bd->link;
251 ws->n_part_blocks -= bd->blocks;
252 }
253 else
254 {
255 // blocks in to-space get the BF_EVACUATED flag.
256
257 // allocBlocks_sync(16, &hd, &tl,
258 // ws->step->gen_no, ws->step, BF_EVACUATED);
259 //
260 // tl->link = ws->part_list;
261 // ws->part_list = hd->link;
262 // ws->n_part_blocks += 15;
263 //
264 // bd = hd;
265
266 if (size > BLOCK_SIZE_W) {
267 bd = allocGroup_sync((lnat)BLOCK_ROUND_UP(size*sizeof(W_))
268 / BLOCK_SIZE);
269 } else {
270 bd = allocBlock_sync();
271 }
272 initBdescr(bd, ws->step);
273 bd->flags = BF_EVACUATED;
274 bd->u.scan = bd->free = bd->start;
275 }
276
277 bd->link = NULL;
278
279 ws->todo_bd = bd;
280 ws->todo_free = bd->free;
281 ws->todo_lim = stg_min(bd->start + bd->blocks * BLOCK_SIZE_W,
282 bd->free + stg_max(WORK_UNIT_WORDS,size));
283
284 debugTrace(DEBUG_gc, "alloc new todo block %p for step %d",
285 bd->free, ws->step->abs_no);
286
287 return ws->todo_free;
288 }
289
290 /* -----------------------------------------------------------------------------
291 * Debugging
292 * -------------------------------------------------------------------------- */
293
294 #if DEBUG
295 void
296 printMutableList(generation *gen)
297 {
298 bdescr *bd;
299 StgPtr p;
300
301 debugBelch("mutable list %p: ", gen->mut_list);
302
303 for (bd = gen->mut_list; bd != NULL; bd = bd->link) {
304 for (p = bd->start; p < bd->free; p++) {
305 debugBelch("%p (%s), ", (void *)*p, info_type((StgClosure *)*p));
306 }
307 }
308 debugBelch("\n");
309 }
310 #endif /* DEBUG */