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