ff3843ecd71327f0e9b68f24a42166c8ece10c5f
[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 /* This hash table maps Haskell objects to stable names, so that every
107 * call to lookupStableName on a given object will return the same
108 * stable name.
109 *
110 * OLD COMMENTS about reference counting follow. The reference count
111 * in a stable name entry is now just a counter.
112 *
113 * Reference counting
114 * ------------------
115 * A plain stable name entry has a zero reference count, which means
116 * the entry will dissappear when the object it points to is
117 * unreachable. For stable pointers, we need an entry that sticks
118 * around and keeps the object it points to alive, so each stable name
119 * entry has an associated reference count.
120 *
121 * A stable pointer has a weighted reference count N attached to it
122 * (actually in its upper 5 bits), which represents the weight
123 * 2^(N-1). The stable name entry keeps a 32-bit reference count, which
124 * represents any weight between 1 and 2^32 (represented as zero).
125 * When the weight is 2^32, the stable name table owns "all" of the
126 * stable pointers to this object, and the entry can be garbage
127 * collected if the object isn't reachable.
128 *
129 * A new stable pointer is given the weight log2(W/2), where W is the
130 * weight stored in the table entry. The new weight in the table is W
131 * - 2^log2(W/2).
132 *
133 * A stable pointer can be "split" into two stable pointers, by
134 * dividing the weight by 2 and giving each pointer half.
135 * When freeing a stable pointer, the weight of the pointer is added
136 * to the weight stored in the table entry.
137 * */
138
139 static HashTable *addrToStableHash = NULL;
140
141 STATIC_INLINE void
142 initSnEntryFreeList(snEntry *table, nat n, snEntry *free)
143 {
144 snEntry *p;
145 for (p = table + n - 1; p >= table; p--) {
146 p->addr = (P_)free;
147 p->old = NULL;
148 p->sn_obj = NULL;
149 free = p;
150 }
151 stable_name_free = table;
152 }
153
154 STATIC_INLINE void
155 initSpEntryFreeList(spEntry *table, nat n, spEntry *free)
156 {
157 spEntry *p;
158 for (p = table + n - 1; p >= table; p--) {
159 p->addr = (P_)free;
160 free = p;
161 }
162 stable_ptr_free = table;
163 }
164
165 void
166 initStableTables(void)
167 {
168 if (SNT_size > 0) return;
169 SNT_size = INIT_SNT_SIZE;
170 stable_name_table = stgMallocBytes(SNT_size * sizeof *stable_name_table,
171 "initStableNameTable");
172 /* we don't use index 0 in the stable name table, because that
173 * would conflict with the hash table lookup operations which
174 * return NULL if an entry isn't found in the hash table.
175 */
176 initSnEntryFreeList(stable_name_table + 1,INIT_SNT_SIZE-1,NULL);
177 addrToStableHash = allocHashTable();
178
179 if (SPT_size > 0) return;
180 SPT_size = INIT_SPT_SIZE;
181 stable_ptr_table = stgMallocBytes(SPT_size * sizeof *stable_ptr_table,
182 "initStablePtrTable");
183 initSpEntryFreeList(stable_ptr_table,INIT_SPT_SIZE,NULL);
184
185 #ifdef THREADED_RTS
186 initMutex(&stable_mutex);
187 #endif
188 }
189
190 void
191 exitStableTables(void)
192 {
193 if (addrToStableHash)
194 freeHashTable(addrToStableHash, NULL);
195 addrToStableHash = NULL;
196
197 if (stable_name_table)
198 stgFree(stable_name_table);
199 stable_name_table = NULL;
200 SNT_size = 0;
201
202 if (stable_ptr_table)
203 stgFree(stable_ptr_table);
204 stable_ptr_table = NULL;
205 SPT_size = 0;
206
207 #ifdef THREADED_RTS
208 closeMutex(&stable_mutex);
209 #endif
210 }
211
212 /*
213 * get at the real stuff...remove indirections.
214 * It untags pointers before dereferencing and
215 * retags the real stuff with its tag (if there
216 * is any) when returning.
217 *
218 * ToDo: move to a better home.
219 */
220 static
221 StgClosure*
222 removeIndirections(StgClosure* p)
223 {
224 StgWord tag = GET_CLOSURE_TAG(p);
225 StgClosure* q = UNTAG_CLOSURE(p);
226
227 while (get_itbl(q)->type == IND ||
228 get_itbl(q)->type == IND_STATIC ||
229 get_itbl(q)->type == IND_PERM) {
230 q = ((StgInd *)q)->indirectee;
231 tag = GET_CLOSURE_TAG(q);
232 q = UNTAG_CLOSURE(q);
233 }
234
235 return TAG_CLOSURE(tag,q);
236 }
237
238 static StgWord
239 lookupStableName_(StgPtr p)
240 {
241 StgWord sn;
242 void* sn_tmp;
243
244 if (stable_name_free == NULL) {
245 enlargeStableNameTable();
246 }
247
248 /* removing indirections increases the likelihood
249 * of finding a match in the stable name hash table.
250 */
251 p = (StgPtr)removeIndirections((StgClosure*)p);
252
253 // register the untagged pointer. This just makes things simpler.
254 p = (StgPtr)UNTAG_CLOSURE((StgClosure*)p);
255
256 sn_tmp = lookupHashTable(addrToStableHash,(W_)p);
257 sn = (StgWord)sn_tmp;
258
259 if (sn != 0) {
260 ASSERT(stable_name_table[sn].addr == p);
261 debugTrace(DEBUG_stable, "cached stable name %ld at %p",sn,p);
262 return sn;
263 }
264
265 sn = stable_name_free - stable_name_table;
266 stable_name_free = (snEntry*)(stable_name_free->addr);
267 stable_name_table[sn].addr = p;
268 stable_name_table[sn].sn_obj = NULL;
269 /* debugTrace(DEBUG_stable, "new stable name %d at %p\n",sn,p); */
270
271 /* add the new stable name to the hash table */
272 insertHashTable(addrToStableHash, (W_)p, (void *)sn);
273
274 return sn;
275 }
276
277 StgWord
278 lookupStableName(StgPtr p)
279 {
280 StgWord res;
281
282 initStableTables();
283 ACQUIRE_LOCK(&stable_mutex);
284 res = lookupStableName_(p);
285 RELEASE_LOCK(&stable_mutex);
286 return res;
287 }
288
289 STATIC_INLINE void
290 freeSnEntry(snEntry *sn)
291 {
292 ASSERT(sn->sn_obj == NULL);
293 if(sn->addr != NULL) {
294 /* StableName object may die before pointee, in which case we
295 * need to remove from hash table, or after pointee, in which
296 * case addr==NULL and we already removed it. */
297 removeHashTable(addrToStableHash, (W_)sn->addr, NULL);
298 }
299 sn->addr = (P_)stable_name_free;
300 stable_name_free = sn;
301 }
302
303 STATIC_INLINE void
304 freeSpEntry(spEntry *sp)
305 {
306 sp->addr = (P_)stable_ptr_free;
307 stable_ptr_free = sp;
308 }
309
310 StgStablePtr
311 getStablePtr(StgPtr p)
312 {
313 StgWord sp;
314
315 initStableTables();
316 ACQUIRE_LOCK(&stable_mutex);
317 if (!stable_ptr_free) enlargeStablePtrTable();
318 sp = stable_ptr_free - stable_ptr_table;
319 stable_ptr_free = (spEntry*)(stable_ptr_free->addr);
320 stable_ptr_table[sp].addr = p;
321 RELEASE_LOCK(&stable_mutex);
322 return (StgStablePtr)(sp);
323 }
324
325 void
326 freeStablePtrUnsafe(StgStablePtr sp)
327 {
328 ASSERT((StgWord)sp < SPT_size);
329 freeSpEntry(&stable_ptr_table[(StgWord)sp]);
330 }
331
332 void
333 freeStablePtr(StgStablePtr sp)
334 {
335 initStableTables();
336 ACQUIRE_LOCK(&stable_mutex);
337 freeStablePtrUnsafe(sp);
338 RELEASE_LOCK(&stable_mutex);
339 }
340
341 static void
342 enlargeStableNameTable(void)
343 {
344 nat old_SNT_size = SNT_size;
345
346 // 2nd and subsequent times
347 SNT_size *= 2;
348 stable_name_table =
349 stgReallocBytes(stable_name_table,
350 SNT_size * sizeof *stable_name_table,
351 "enlargeStableNameTable");
352
353 initSnEntryFreeList(stable_name_table + old_SNT_size, old_SNT_size, NULL);
354 }
355
356 static void
357 enlargeStablePtrTable(void)
358 {
359 nat old_SPT_size = SPT_size;
360
361 // 2nd and subsequent times
362 SPT_size *= 2;
363 stable_ptr_table =
364 stgReallocBytes(stable_ptr_table,
365 SPT_size * sizeof *stable_ptr_table,
366 "enlargeStablePtrTable");
367
368 initSpEntryFreeList(stable_ptr_table + old_SPT_size, old_SPT_size, NULL);
369 }
370
371 /* -----------------------------------------------------------------------------
372 * We must lock the StablePtr table during GC, to prevent simultaneous
373 * calls to freeStablePtr().
374 * -------------------------------------------------------------------------- */
375
376 void
377 stableLock(void)
378 {
379 initStableTables();
380 ACQUIRE_LOCK(&stable_mutex);
381 }
382
383 void
384 stableUnlock(void)
385 {
386 RELEASE_LOCK(&stable_mutex);
387 }
388
389 /* -----------------------------------------------------------------------------
390 * Treat stable pointers as roots for the garbage collector.
391 * -------------------------------------------------------------------------- */
392
393 #define FOR_EACH_STABLE_PTR(p, CODE) \
394 do { \
395 spEntry *p; \
396 spEntry *__end_ptr = &stable_ptr_table[SPT_size]; \
397 for (p = stable_ptr_table; p < __end_ptr; p++) { \
398 /* Internal pointers are free slots. NULL is last in free */ \
399 /* list. */ \
400 if (p->addr && \
401 (p->addr < (P_)stable_ptr_table || p->addr >= (P_)__end_ptr)) \
402 { \
403 do { CODE } while(0); \
404 } \
405 } \
406 } while(0)
407
408 #define FOR_EACH_STABLE_NAME(p, CODE) \
409 do { \
410 snEntry *p; \
411 snEntry *__end_ptr = &stable_name_table[SNT_size]; \
412 for (p = stable_name_table + 1; p < __end_ptr; p++) { \
413 /* Internal pointers are free slots. */ \
414 /* If p->addr == NULL, it's a */ \
415 /* stable name where the object has been GC'd, but the */ \
416 /* StableName object (sn_obj) is still alive. */ \
417 if ((p->addr < (P_)stable_name_table || \
418 p->addr >= (P_)__end_ptr)) \
419 { \
420 /* NOTE: There is an ambiguity here if p->addr == NULL */ \
421 /* it is either the last item in the free list or it */ \
422 /* is a stable name whose pointee died. sn_obj == NULL */ \
423 /* disambiguates as last free list item. */ \
424 do { CODE } while(0); \
425 } \
426 } \
427 } while(0)
428
429 STATIC_INLINE void
430 markStablePtrTable(evac_fn evac, void *user)
431 {
432 FOR_EACH_STABLE_PTR(p, evac(user, (StgClosure **)&p->addr););
433 }
434
435 STATIC_INLINE void
436 rememberOldStableNameAddresses(void)
437 {
438 /* TODO: Only if !full GC */
439 FOR_EACH_STABLE_NAME(p, p->old = p->addr;);
440 }
441
442 void
443 markStableTables(evac_fn evac, void *user)
444 {
445 markStablePtrTable(evac, user);
446 rememberOldStableNameAddresses();
447 }
448
449 /* -----------------------------------------------------------------------------
450 * Thread the stable pointer table for compacting GC.
451 *
452 * Here we must call the supplied evac function for each pointer into
453 * the heap from the stable tables, because the compacting
454 * collector may move the object it points to.
455 * -------------------------------------------------------------------------- */
456
457 STATIC_INLINE void
458 threadStableNameTable( evac_fn evac, void *user )
459 {
460 FOR_EACH_STABLE_NAME(p, {
461 if (p->sn_obj != NULL) {
462 evac(user, (StgClosure **)&p->sn_obj);
463 }
464 if (p->addr != NULL) {
465 evac(user, (StgClosure **)&p->addr);
466 }
467 });
468 }
469
470 STATIC_INLINE void
471 threadStablePtrTable( evac_fn evac, void *user )
472 {
473 FOR_EACH_STABLE_PTR(p, evac(user, (StgClosure **)&p->addr););
474 }
475
476 void
477 threadStableTables( evac_fn evac, void *user )
478 {
479 threadStableNameTable(evac, user);
480 threadStablePtrTable(evac, user);
481 }
482
483 /* -----------------------------------------------------------------------------
484 * Garbage collect any dead entries in the stable pointer table.
485 *
486 * A dead entry has:
487 *
488 * - a zero reference count
489 * - a dead sn_obj
490 *
491 * Both of these conditions must be true in order to re-use the stable
492 * name table entry. We can re-use stable name table entries for live
493 * heap objects, as long as the program has no StableName objects that
494 * refer to the entry.
495 * -------------------------------------------------------------------------- */
496
497 void
498 gcStableTables( void )
499 {
500 FOR_EACH_STABLE_NAME(
501 p, {
502 // Update the pointer to the StableName object, if there is one
503 if (p->sn_obj != NULL) {
504 p->sn_obj = isAlive(p->sn_obj);
505 if(p->sn_obj == NULL) {
506 // StableName object died
507 debugTrace(DEBUG_stable, "GC'd StableName %ld (addr=%p)",
508 (long)(p - stable_name_table), p->addr);
509 freeSnEntry(p);
510 /* Can't "continue", so use goto */
511 goto next_stable_name;
512 }
513 }
514 /* If sn_obj became NULL, the object died, and addr is now
515 * invalid. But if sn_obj was null, then the StableName
516 * object may not have been created yet, while the pointee
517 * already exists and must be updated to new location. */
518 if (p->addr != NULL) {
519 p->addr = (StgPtr)isAlive((StgClosure *)p->addr);
520 if(p->addr == NULL) {
521 // StableName pointee died
522 debugTrace(DEBUG_stable, "GC'd pointee %ld",
523 (long)(p - stable_name_table));
524 }
525 }
526 next_stable_name:
527 if (0) {}
528 });
529 }
530
531 /* -----------------------------------------------------------------------------
532 * Update the StableName hash table
533 *
534 * The boolean argument 'full' indicates that a major collection is
535 * being done, so we might as well throw away the hash table and build
536 * a new one. For a minor collection, we just re-hash the elements
537 * that changed.
538 * -------------------------------------------------------------------------- */
539
540 void
541 updateStableTables(rtsBool full)
542 {
543 if (full && addrToStableHash != NULL && 0 != keyCountHashTable(addrToStableHash)) {
544 freeHashTable(addrToStableHash,NULL);
545 addrToStableHash = allocHashTable();
546 }
547
548 if(full) {
549 FOR_EACH_STABLE_NAME(
550 p, {
551 if (p->addr != NULL) {
552 // Target still alive, Re-hash this stable name
553 insertHashTable(addrToStableHash, (W_)p->addr, (void *)(p - stable_name_table));
554 }
555 });
556 } else {
557 FOR_EACH_STABLE_NAME(
558 p, {
559 if (p->addr != p->old) {
560 removeHashTable(addrToStableHash, (W_)p->old, NULL);
561 /* Movement happened: */
562 if (p->addr != NULL) {
563 insertHashTable(addrToStableHash, (W_)p->addr, (void *)(p - stable_name_table));
564 }
565 }
566 });
567 }
568 }