Zonk the existential type variables in tcPatSynDecl
[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://ghc.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 */
282 static StgClosure*
283 removeIndirections (StgClosure* p)
284 {
285 StgClosure* q;
286
287 while (1)
288 {
289 q = UNTAG_CLOSURE(p);
290
291 switch (get_itbl(q)->type) {
292 case IND:
293 case IND_STATIC:
294 case IND_PERM:
295 p = ((StgInd *)q)->indirectee;
296 continue;
297
298 case BLACKHOLE:
299 p = ((StgInd *)q)->indirectee;
300 if (GET_CLOSURE_TAG(p) != 0) {
301 continue;
302 } else {
303 break;
304 }
305
306 default:
307 break;
308 }
309 return p;
310 }
311 }
312
313 StgWord
314 lookupStableName (StgPtr p)
315 {
316 StgWord sn;
317 void* sn_tmp;
318
319 stableLock();
320
321 if (stable_name_free == NULL) {
322 enlargeStableNameTable();
323 }
324
325 /* removing indirections increases the likelihood
326 * of finding a match in the stable name hash table.
327 */
328 p = (StgPtr)removeIndirections((StgClosure*)p);
329
330 // register the untagged pointer. This just makes things simpler.
331 p = (StgPtr)UNTAG_CLOSURE((StgClosure*)p);
332
333 sn_tmp = lookupHashTable(addrToStableHash,(W_)p);
334 sn = (StgWord)sn_tmp;
335
336 if (sn != 0) {
337 ASSERT(stable_name_table[sn].addr == p);
338 debugTrace(DEBUG_stable, "cached stable name %ld at %p",sn,p);
339 stableUnlock();
340 return sn;
341 }
342
343 sn = stable_name_free - stable_name_table;
344 stable_name_free = (snEntry*)(stable_name_free->addr);
345 stable_name_table[sn].addr = p;
346 stable_name_table[sn].sn_obj = NULL;
347 /* debugTrace(DEBUG_stable, "new stable name %d at %p\n",sn,p); */
348
349 /* add the new stable name to the hash table */
350 insertHashTable(addrToStableHash, (W_)p, (void *)sn);
351
352 stableUnlock();
353
354 return sn;
355 }
356
357 StgStablePtr
358 getStablePtr(StgPtr p)
359 {
360 StgWord sp;
361
362 stableLock();
363 if (!stable_ptr_free) enlargeStablePtrTable();
364 sp = stable_ptr_free - stable_ptr_table;
365 stable_ptr_free = (spEntry*)(stable_ptr_free->addr);
366 stable_ptr_table[sp].addr = p;
367 stableUnlock();
368 return (StgStablePtr)(sp);
369 }
370
371 /* -----------------------------------------------------------------------------
372 * Treat stable pointers as roots for the garbage collector.
373 * -------------------------------------------------------------------------- */
374
375 #define FOR_EACH_STABLE_PTR(p, CODE) \
376 do { \
377 spEntry *p; \
378 spEntry *__end_ptr = &stable_ptr_table[SPT_size]; \
379 for (p = stable_ptr_table; p < __end_ptr; p++) { \
380 /* Internal pointers are free slots. NULL is last in free */ \
381 /* list. */ \
382 if (p->addr && \
383 (p->addr < (P_)stable_ptr_table || p->addr >= (P_)__end_ptr)) \
384 { \
385 do { CODE } while(0); \
386 } \
387 } \
388 } while(0)
389
390 #define FOR_EACH_STABLE_NAME(p, CODE) \
391 do { \
392 snEntry *p; \
393 snEntry *__end_ptr = &stable_name_table[SNT_size]; \
394 for (p = stable_name_table + 1; p < __end_ptr; p++) { \
395 /* Internal pointers are free slots. */ \
396 /* If p->addr == NULL, it's a */ \
397 /* stable name where the object has been GC'd, but the */ \
398 /* StableName object (sn_obj) is still alive. */ \
399 if ((p->addr < (P_)stable_name_table || \
400 p->addr >= (P_)__end_ptr)) \
401 { \
402 /* NOTE: There is an ambiguity here if p->addr == NULL */ \
403 /* it is either the last item in the free list or it */ \
404 /* is a stable name whose pointee died. sn_obj == NULL */ \
405 /* disambiguates as last free list item. */ \
406 do { CODE } while(0); \
407 } \
408 } \
409 } while(0)
410
411 STATIC_INLINE void
412 markStablePtrTable(evac_fn evac, void *user)
413 {
414 FOR_EACH_STABLE_PTR(p, evac(user, (StgClosure **)&p->addr););
415 }
416
417 STATIC_INLINE void
418 rememberOldStableNameAddresses(void)
419 {
420 /* TODO: Only if !full GC */
421 FOR_EACH_STABLE_NAME(p, p->old = p->addr;);
422 }
423
424 void
425 markStableTables(evac_fn evac, void *user)
426 {
427 markStablePtrTable(evac, user);
428 rememberOldStableNameAddresses();
429 }
430
431 /* -----------------------------------------------------------------------------
432 * Thread the stable pointer table for compacting GC.
433 *
434 * Here we must call the supplied evac function for each pointer into
435 * the heap from the stable tables, because the compacting
436 * collector may move the object it points to.
437 * -------------------------------------------------------------------------- */
438
439 STATIC_INLINE void
440 threadStableNameTable( evac_fn evac, void *user )
441 {
442 FOR_EACH_STABLE_NAME(p, {
443 if (p->sn_obj != NULL) {
444 evac(user, (StgClosure **)&p->sn_obj);
445 }
446 if (p->addr != NULL) {
447 evac(user, (StgClosure **)&p->addr);
448 }
449 });
450 }
451
452 STATIC_INLINE void
453 threadStablePtrTable( evac_fn evac, void *user )
454 {
455 FOR_EACH_STABLE_PTR(p, evac(user, (StgClosure **)&p->addr););
456 }
457
458 void
459 threadStableTables( evac_fn evac, void *user )
460 {
461 threadStableNameTable(evac, user);
462 threadStablePtrTable(evac, user);
463 }
464
465 /* -----------------------------------------------------------------------------
466 * Garbage collect any dead entries in the stable pointer table.
467 *
468 * A dead entry has:
469 *
470 * - a zero reference count
471 * - a dead sn_obj
472 *
473 * Both of these conditions must be true in order to re-use the stable
474 * name table entry. We can re-use stable name table entries for live
475 * heap objects, as long as the program has no StableName objects that
476 * refer to the entry.
477 * -------------------------------------------------------------------------- */
478
479 void
480 gcStableTables( void )
481 {
482 FOR_EACH_STABLE_NAME(
483 p, {
484 // Update the pointer to the StableName object, if there is one
485 if (p->sn_obj != NULL) {
486 p->sn_obj = isAlive(p->sn_obj);
487 if(p->sn_obj == NULL) {
488 // StableName object died
489 debugTrace(DEBUG_stable, "GC'd StableName %ld (addr=%p)",
490 (long)(p - stable_name_table), p->addr);
491 freeSnEntry(p);
492 /* Can't "continue", so use goto */
493 goto next_stable_name;
494 }
495 }
496 /* If sn_obj became NULL, the object died, and addr is now
497 * invalid. But if sn_obj was null, then the StableName
498 * object may not have been created yet, while the pointee
499 * already exists and must be updated to new location. */
500 if (p->addr != NULL) {
501 p->addr = (StgPtr)isAlive((StgClosure *)p->addr);
502 if(p->addr == NULL) {
503 // StableName pointee died
504 debugTrace(DEBUG_stable, "GC'd pointee %ld",
505 (long)(p - stable_name_table));
506 }
507 }
508 next_stable_name:
509 if (0) {}
510 });
511 }
512
513 /* -----------------------------------------------------------------------------
514 * Update the StableName hash table
515 *
516 * The boolean argument 'full' indicates that a major collection is
517 * being done, so we might as well throw away the hash table and build
518 * a new one. For a minor collection, we just re-hash the elements
519 * that changed.
520 * -------------------------------------------------------------------------- */
521
522 void
523 updateStableTables(rtsBool full)
524 {
525 if (full && addrToStableHash != NULL && 0 != keyCountHashTable(addrToStableHash)) {
526 freeHashTable(addrToStableHash,NULL);
527 addrToStableHash = allocHashTable();
528 }
529
530 if(full) {
531 FOR_EACH_STABLE_NAME(
532 p, {
533 if (p->addr != NULL) {
534 // Target still alive, Re-hash this stable name
535 insertHashTable(addrToStableHash, (W_)p->addr, (void *)(p - stable_name_table));
536 }
537 });
538 } else {
539 FOR_EACH_STABLE_NAME(
540 p, {
541 if (p->addr != p->old) {
542 removeHashTable(addrToStableHash, (W_)p->old, NULL);
543 /* Movement happened: */
544 if (p->addr != NULL) {
545 insertHashTable(addrToStableHash, (W_)p->addr, (void *)(p - stable_name_table));
546 }
547 }
548 });
549 }
550 }