small tidyups and refactorings
[ghc.git] / rts / Stable.c
1 /* -*- tab-width: 4 -*- */
2
3 /* -----------------------------------------------------------------------------
4 *
5 * (c) The GHC Team, 1998-2002
6 *
7 * Stable names and stable pointers.
8 *
9 * ---------------------------------------------------------------------------*/
10
11 #include "PosixSource.h"
12 #include "Rts.h"
13 #include "RtsAPI.h"
14
15 #include "Hash.h"
16 #include "RtsUtils.h"
17 #include "Trace.h"
18 #include "Stable.h"
19
20 /* Comment from ADR's implementation in old RTS:
21
22 This files (together with @ghc/runtime/storage/PerformIO.lhc@ and a
23 small change in @HpOverflow.lc@) consists of the changes in the
24 runtime system required to implement "Stable Pointers". But we're
25 getting a bit ahead of ourselves --- what is a stable pointer and what
26 is it used for?
27
28 When Haskell calls C, it normally just passes over primitive integers,
29 floats, bools, strings, etc. This doesn't cause any problems at all
30 for garbage collection because the act of passing them makes a copy
31 from the heap, stack or wherever they are onto the C-world stack.
32 However, if we were to pass a heap object such as a (Haskell) @String@
33 and a garbage collection occured before we finished using it, we'd run
34 into problems since the heap object might have been moved or even
35 deleted.
36
37 So, if a C call is able to cause a garbage collection or we want to
38 store a pointer to a heap object between C calls, we must be careful
39 when passing heap objects. Our solution is to keep a table of all
40 objects we've given to the C-world and to make sure that the garbage
41 collector collects these objects --- updating the table as required to
42 make sure we can still find the object.
43
44
45 Of course, all this rather begs the question: why would we want to
46 pass a boxed value?
47
48 One very good reason is to preserve laziness across the language
49 interface. Rather than evaluating an integer or a string because it
50 {\em might\/} be required by the C function, we can wait until the C
51 function actually wants the value and then force an evaluation.
52
53 Another very good reason (the motivating reason!) is that the C code
54 might want to execute an object of sort $IO ()$ for the side-effects
55 it will produce. For example, this is used when interfacing to an X
56 widgets library to allow a direct implementation of callbacks.
57
58 One final reason is that we may want to store composite Haskell
59 values in data structures implemented in the C side. Serializing and
60 deserializing these structures into unboxed form suitable for C may
61 be more expensive than maintaining the extra layer of indirection of
62 stable pointers.
63
64 The @makeStablePointer :: a -> IO (StablePtr a)@ function
65 converts a value into a stable pointer. It is part of the @PrimIO@
66 monad, because we want to be sure we don't allocate one twice by
67 accident, and then only free one of the copies.
68
69 \begin{verbatim}
70 makeStablePtr# :: a -> State# RealWorld -> (# RealWorld, a #)
71 freeStablePtr# :: StablePtr# a -> State# RealWorld -> State# RealWorld
72 deRefStablePtr# :: StablePtr# a -> State# RealWorld ->
73 (# State# RealWorld, a #)
74 \end{verbatim}
75
76 There may be additional functions on the C side to allow evaluation,
77 application, etc of a stable pointer.
78
79 Stable Pointers are exported to the outside world as indices and not
80 pointers, because the stable pointer table is allowed to be
81 reallocated for growth. The table is never shrunk for its space to
82 be reclaimed.
83
84 Future plans for stable ptrs include distinguishing them by the
85 generation of the pointed object. See
86 http://hackage.haskell.org/trac/ghc/ticket/7670 for details.
87 */
88
89 snEntry *stable_name_table = NULL;
90 static snEntry *stable_name_free = NULL;
91 static unsigned int SNT_size = 0;
92 #define INIT_SNT_SIZE 64
93
94 spEntry *stable_ptr_table = NULL;
95 static spEntry *stable_ptr_free = NULL;
96 static unsigned int SPT_size = 0;
97 #define INIT_SPT_SIZE 64
98
99 #ifdef THREADED_RTS
100 Mutex stable_mutex;
101 #endif
102
103 static void enlargeStableNameTable(void);
104 static void enlargeStablePtrTable(void);
105
106 /*
107 * This hash table maps Haskell objects to stable names, so that every
108 * call to lookupStableName on a given object will return the same
109 * stable name.
110 */
111
112 static HashTable *addrToStableHash = NULL;
113
114 /* -----------------------------------------------------------------------------
115 * We must lock the StablePtr table during GC, to prevent simultaneous
116 * calls to freeStablePtr().
117 * -------------------------------------------------------------------------- */
118
119 void
120 stableLock(void)
121 {
122 initStableTables();
123 ACQUIRE_LOCK(&stable_mutex);
124 }
125
126 void
127 stableUnlock(void)
128 {
129 RELEASE_LOCK(&stable_mutex);
130 }
131
132 /* -----------------------------------------------------------------------------
133 * Initialising the tables
134 * -------------------------------------------------------------------------- */
135
136 STATIC_INLINE void
137 initSnEntryFreeList(snEntry *table, nat n, snEntry *free)
138 {
139 snEntry *p;
140 for (p = table + n - 1; p >= table; p--) {
141 p->addr = (P_)free;
142 p->old = NULL;
143 p->sn_obj = NULL;
144 free = p;
145 }
146 stable_name_free = table;
147 }
148
149 STATIC_INLINE void
150 initSpEntryFreeList(spEntry *table, nat n, spEntry *free)
151 {
152 spEntry *p;
153 for (p = table + n - 1; p >= table; p--) {
154 p->addr = (P_)free;
155 free = p;
156 }
157 stable_ptr_free = table;
158 }
159
160 void
161 initStableTables(void)
162 {
163 if (SNT_size > 0) return;
164 SNT_size = INIT_SNT_SIZE;
165 stable_name_table = stgMallocBytes(SNT_size * sizeof *stable_name_table,
166 "initStableNameTable");
167 /* we don't use index 0 in the stable name table, because that
168 * would conflict with the hash table lookup operations which
169 * return NULL if an entry isn't found in the hash table.
170 */
171 initSnEntryFreeList(stable_name_table + 1,INIT_SNT_SIZE-1,NULL);
172 addrToStableHash = allocHashTable();
173
174 if (SPT_size > 0) return;
175 SPT_size = INIT_SPT_SIZE;
176 stable_ptr_table = stgMallocBytes(SPT_size * sizeof *stable_ptr_table,
177 "initStablePtrTable");
178 initSpEntryFreeList(stable_ptr_table,INIT_SPT_SIZE,NULL);
179
180 #ifdef THREADED_RTS
181 initMutex(&stable_mutex);
182 #endif
183 }
184
185 /* -----------------------------------------------------------------------------
186 * Enlarging the tables
187 * -------------------------------------------------------------------------- */
188
189 static void
190 enlargeStableNameTable(void)
191 {
192 nat old_SNT_size = SNT_size;
193
194 // 2nd and subsequent times
195 SNT_size *= 2;
196 stable_name_table =
197 stgReallocBytes(stable_name_table,
198 SNT_size * sizeof *stable_name_table,
199 "enlargeStableNameTable");
200
201 initSnEntryFreeList(stable_name_table + old_SNT_size, old_SNT_size, NULL);
202 }
203
204 static void
205 enlargeStablePtrTable(void)
206 {
207 nat old_SPT_size = SPT_size;
208
209 // 2nd and subsequent times
210 SPT_size *= 2;
211 stable_ptr_table =
212 stgReallocBytes(stable_ptr_table,
213 SPT_size * sizeof *stable_ptr_table,
214 "enlargeStablePtrTable");
215
216 initSpEntryFreeList(stable_ptr_table + old_SPT_size, old_SPT_size, NULL);
217 }
218
219 /* -----------------------------------------------------------------------------
220 * Freeing entries and tables
221 * -------------------------------------------------------------------------- */
222
223 void
224 exitStableTables(void)
225 {
226 if (addrToStableHash)
227 freeHashTable(addrToStableHash, NULL);
228 addrToStableHash = NULL;
229
230 if (stable_name_table)
231 stgFree(stable_name_table);
232 stable_name_table = NULL;
233 SNT_size = 0;
234
235 if (stable_ptr_table)
236 stgFree(stable_ptr_table);
237 stable_ptr_table = NULL;
238 SPT_size = 0;
239
240 #ifdef THREADED_RTS
241 closeMutex(&stable_mutex);
242 #endif
243 }
244
245 STATIC_INLINE void
246 freeSnEntry(snEntry *sn)
247 {
248 ASSERT(sn->sn_obj == NULL);
249 sn->addr = (P_)stable_name_free;
250 stable_name_free = sn;
251 }
252
253 STATIC_INLINE void
254 freeSpEntry(spEntry *sp)
255 {
256 sp->addr = (P_)stable_ptr_free;
257 stable_ptr_free = sp;
258 }
259
260 void
261 freeStablePtrUnsafe(StgStablePtr sp)
262 {
263 ASSERT((StgWord)sp < SPT_size);
264 freeSpEntry(&stable_ptr_table[(StgWord)sp]);
265 }
266
267 void
268 freeStablePtr(StgStablePtr sp)
269 {
270 stableLock();
271 freeStablePtrUnsafe(sp);
272 stableUnlock();
273 }
274
275 /* -----------------------------------------------------------------------------
276 * Looking up
277 * -------------------------------------------------------------------------- */
278
279 /*
280 * get at the real stuff...remove indirections.
281 * It untags pointers before dereferencing and
282 * retags the real stuff with its tag (if there
283 * is any) when returning.
284 *
285 * ToDo: move to a better home.
286 */
287 static
288 StgClosure*
289 removeIndirections(StgClosure* p)
290 {
291 StgWord tag = GET_CLOSURE_TAG(p);
292 StgClosure* q = UNTAG_CLOSURE(p);
293
294 while (get_itbl(q)->type == IND ||
295 get_itbl(q)->type == IND_STATIC ||
296 get_itbl(q)->type == IND_PERM) {
297 q = ((StgInd *)q)->indirectee;
298 tag = GET_CLOSURE_TAG(q);
299 q = UNTAG_CLOSURE(q);
300 }
301
302 return TAG_CLOSURE(tag,q);
303 }
304
305 StgWord
306 lookupStableName (StgPtr p)
307 {
308 StgWord sn;
309 void* sn_tmp;
310
311 stableLock();
312
313 if (stable_name_free == NULL) {
314 enlargeStableNameTable();
315 }
316
317 /* removing indirections increases the likelihood
318 * of finding a match in the stable name hash table.
319 */
320 p = (StgPtr)removeIndirections((StgClosure*)p);
321
322 // register the untagged pointer. This just makes things simpler.
323 p = (StgPtr)UNTAG_CLOSURE((StgClosure*)p);
324
325 sn_tmp = lookupHashTable(addrToStableHash,(W_)p);
326 sn = (StgWord)sn_tmp;
327
328 if (sn != 0) {
329 ASSERT(stable_name_table[sn].addr == p);
330 debugTrace(DEBUG_stable, "cached stable name %ld at %p",sn,p);
331 stableUnlock();
332 return sn;
333 }
334
335 sn = stable_name_free - stable_name_table;
336 stable_name_free = (snEntry*)(stable_name_free->addr);
337 stable_name_table[sn].addr = p;
338 stable_name_table[sn].sn_obj = NULL;
339 /* debugTrace(DEBUG_stable, "new stable name %d at %p\n",sn,p); */
340
341 /* add the new stable name to the hash table */
342 insertHashTable(addrToStableHash, (W_)p, (void *)sn);
343
344 stableUnlock();
345
346 return sn;
347 }
348
349 StgStablePtr
350 getStablePtr(StgPtr p)
351 {
352 StgWord sp;
353
354 stableLock();
355 if (!stable_ptr_free) enlargeStablePtrTable();
356 sp = stable_ptr_free - stable_ptr_table;
357 stable_ptr_free = (spEntry*)(stable_ptr_free->addr);
358 stable_ptr_table[sp].addr = p;
359 stableUnlock();
360 return (StgStablePtr)(sp);
361 }
362
363 /* -----------------------------------------------------------------------------
364 * Treat stable pointers as roots for the garbage collector.
365 * -------------------------------------------------------------------------- */
366
367 #define FOR_EACH_STABLE_PTR(p, CODE) \
368 do { \
369 spEntry *p; \
370 spEntry *__end_ptr = &stable_ptr_table[SPT_size]; \
371 for (p = stable_ptr_table; p < __end_ptr; p++) { \
372 /* Internal pointers are free slots. NULL is last in free */ \
373 /* list. */ \
374 if (p->addr && \
375 (p->addr < (P_)stable_ptr_table || p->addr >= (P_)__end_ptr)) \
376 { \
377 do { CODE } while(0); \
378 } \
379 } \
380 } while(0)
381
382 #define FOR_EACH_STABLE_NAME(p, CODE) \
383 do { \
384 snEntry *p; \
385 snEntry *__end_ptr = &stable_name_table[SNT_size]; \
386 for (p = stable_name_table + 1; p < __end_ptr; p++) { \
387 /* Internal pointers are free slots. */ \
388 /* If p->addr == NULL, it's a */ \
389 /* stable name where the object has been GC'd, but the */ \
390 /* StableName object (sn_obj) is still alive. */ \
391 if ((p->addr < (P_)stable_name_table || \
392 p->addr >= (P_)__end_ptr)) \
393 { \
394 /* NOTE: There is an ambiguity here if p->addr == NULL */ \
395 /* it is either the last item in the free list or it */ \
396 /* is a stable name whose pointee died. sn_obj == NULL */ \
397 /* disambiguates as last free list item. */ \
398 do { CODE } while(0); \
399 } \
400 } \
401 } while(0)
402
403 STATIC_INLINE void
404 markStablePtrTable(evac_fn evac, void *user)
405 {
406 FOR_EACH_STABLE_PTR(p, evac(user, (StgClosure **)&p->addr););
407 }
408
409 STATIC_INLINE void
410 rememberOldStableNameAddresses(void)
411 {
412 /* TODO: Only if !full GC */
413 FOR_EACH_STABLE_NAME(p, p->old = p->addr;);
414 }
415
416 void
417 markStableTables(evac_fn evac, void *user)
418 {
419 markStablePtrTable(evac, user);
420 rememberOldStableNameAddresses();
421 }
422
423 /* -----------------------------------------------------------------------------
424 * Thread the stable pointer table for compacting GC.
425 *
426 * Here we must call the supplied evac function for each pointer into
427 * the heap from the stable tables, because the compacting
428 * collector may move the object it points to.
429 * -------------------------------------------------------------------------- */
430
431 STATIC_INLINE void
432 threadStableNameTable( evac_fn evac, void *user )
433 {
434 FOR_EACH_STABLE_NAME(p, {
435 if (p->sn_obj != NULL) {
436 evac(user, (StgClosure **)&p->sn_obj);
437 }
438 if (p->addr != NULL) {
439 evac(user, (StgClosure **)&p->addr);
440 }
441 });
442 }
443
444 STATIC_INLINE void
445 threadStablePtrTable( evac_fn evac, void *user )
446 {
447 FOR_EACH_STABLE_PTR(p, evac(user, (StgClosure **)&p->addr););
448 }
449
450 void
451 threadStableTables( evac_fn evac, void *user )
452 {
453 threadStableNameTable(evac, user);
454 threadStablePtrTable(evac, user);
455 }
456
457 /* -----------------------------------------------------------------------------
458 * Garbage collect any dead entries in the stable pointer table.
459 *
460 * A dead entry has:
461 *
462 * - a zero reference count
463 * - a dead sn_obj
464 *
465 * Both of these conditions must be true in order to re-use the stable
466 * name table entry. We can re-use stable name table entries for live
467 * heap objects, as long as the program has no StableName objects that
468 * refer to the entry.
469 * -------------------------------------------------------------------------- */
470
471 void
472 gcStableTables( void )
473 {
474 FOR_EACH_STABLE_NAME(
475 p, {
476 // Update the pointer to the StableName object, if there is one
477 if (p->sn_obj != NULL) {
478 p->sn_obj = isAlive(p->sn_obj);
479 if(p->sn_obj == NULL) {
480 // StableName object died
481 debugTrace(DEBUG_stable, "GC'd StableName %ld (addr=%p)",
482 (long)(p - stable_name_table), p->addr);
483 freeSnEntry(p);
484 /* Can't "continue", so use goto */
485 goto next_stable_name;
486 }
487 }
488 /* If sn_obj became NULL, the object died, and addr is now
489 * invalid. But if sn_obj was null, then the StableName
490 * object may not have been created yet, while the pointee
491 * already exists and must be updated to new location. */
492 if (p->addr != NULL) {
493 p->addr = (StgPtr)isAlive((StgClosure *)p->addr);
494 if(p->addr == NULL) {
495 // StableName pointee died
496 debugTrace(DEBUG_stable, "GC'd pointee %ld",
497 (long)(p - stable_name_table));
498 }
499 }
500 next_stable_name:
501 if (0) {}
502 });
503 }
504
505 /* -----------------------------------------------------------------------------
506 * Update the StableName hash table
507 *
508 * The boolean argument 'full' indicates that a major collection is
509 * being done, so we might as well throw away the hash table and build
510 * a new one. For a minor collection, we just re-hash the elements
511 * that changed.
512 * -------------------------------------------------------------------------- */
513
514 void
515 updateStableTables(rtsBool full)
516 {
517 if (full && addrToStableHash != NULL && 0 != keyCountHashTable(addrToStableHash)) {
518 freeHashTable(addrToStableHash,NULL);
519 addrToStableHash = allocHashTable();
520 }
521
522 if(full) {
523 FOR_EACH_STABLE_NAME(
524 p, {
525 if (p->addr != NULL) {
526 // Target still alive, Re-hash this stable name
527 insertHashTable(addrToStableHash, (W_)p->addr, (void *)(p - stable_name_table));
528 }
529 });
530 } else {
531 FOR_EACH_STABLE_NAME(
532 p, {
533 if (p->addr != p->old) {
534 removeHashTable(addrToStableHash, (W_)p->old, NULL);
535 /* Movement happened: */
536 if (p->addr != NULL) {
537 insertHashTable(addrToStableHash, (W_)p->addr, (void *)(p - stable_name_table));
538 }
539 }
540 });
541 }
542 }