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