ghci: Ensure that system libffi include path is searched
[ghc.git] / rts / StableName.c
1 /* -*- tab-width: 4 -*- */
2
3 /* -----------------------------------------------------------------------------
4 *
5 * (c) The GHC Team, 1998-2002
6 *
7 * Stable names
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 "StableName.h"
19
20 #include <string.h>
21
22 snEntry *stable_name_table = NULL;
23 static snEntry *stable_name_free = NULL;
24 static unsigned int SNT_size = 0;
25 #define INIT_SNT_SIZE 64
26
27 #if defined(THREADED_RTS)
28 Mutex stable_name_mutex;
29 #endif
30
31 static void enlargeStableNameTable(void);
32
33 /*
34 * This hash table maps Haskell objects to stable names, so that every
35 * call to lookupStableName on a given object will return the same
36 * stable name.
37 */
38
39 static HashTable *addrToStableHash = NULL;
40
41 void
42 stableNameLock(void)
43 {
44 initStableNameTable();
45 ACQUIRE_LOCK(&stable_name_mutex);
46 }
47
48 void
49 stableNameUnlock(void)
50 {
51 RELEASE_LOCK(&stable_name_mutex);
52 }
53
54 /* -----------------------------------------------------------------------------
55 * Initialising the table
56 * -------------------------------------------------------------------------- */
57
58 STATIC_INLINE void
59 initSnEntryFreeList(snEntry *table, uint32_t n, snEntry *free)
60 {
61 snEntry *p;
62 for (p = table + n - 1; p >= table; p--) {
63 p->addr = (P_)free;
64 p->old = NULL;
65 p->sn_obj = NULL;
66 free = p;
67 }
68 stable_name_free = table;
69 }
70
71 void
72 initStableNameTable(void)
73 {
74 if (SNT_size > 0) return;
75 SNT_size = INIT_SNT_SIZE;
76 stable_name_table = stgMallocBytes(SNT_size * sizeof(snEntry),
77 "initStableNameTable");
78 /* we don't use index 0 in the stable name table, because that
79 * would conflict with the hash table lookup operations which
80 * return NULL if an entry isn't found in the hash table.
81 */
82 initSnEntryFreeList(stable_name_table + 1,INIT_SNT_SIZE-1,NULL);
83 addrToStableHash = allocHashTable();
84
85 #if defined(THREADED_RTS)
86 initMutex(&stable_name_mutex);
87 #endif
88 }
89
90 /* -----------------------------------------------------------------------------
91 * Enlarging the tables
92 * -------------------------------------------------------------------------- */
93
94 static void
95 enlargeStableNameTable(void)
96 {
97 uint32_t old_SNT_size = SNT_size;
98
99 // 2nd and subsequent times
100 SNT_size *= 2;
101 stable_name_table =
102 stgReallocBytes(stable_name_table,
103 SNT_size * sizeof(snEntry),
104 "enlargeStableNameTable");
105
106 initSnEntryFreeList(stable_name_table + old_SNT_size, old_SNT_size, NULL);
107 }
108
109
110 /* -----------------------------------------------------------------------------
111 * Freeing entries and tables
112 * -------------------------------------------------------------------------- */
113
114 void
115 exitStableNameTable(void)
116 {
117 if (addrToStableHash)
118 freeHashTable(addrToStableHash, NULL);
119 addrToStableHash = NULL;
120
121 if (stable_name_table)
122 stgFree(stable_name_table);
123 stable_name_table = NULL;
124 SNT_size = 0;
125
126 #if defined(THREADED_RTS)
127 closeMutex(&stable_name_mutex);
128 #endif
129 }
130
131 STATIC_INLINE void
132 freeSnEntry(snEntry *sn)
133 {
134 ASSERT(sn->sn_obj == NULL);
135 removeHashTable(addrToStableHash, (W_)sn->old, NULL);
136 sn->addr = (P_)stable_name_free;
137 stable_name_free = sn;
138 }
139
140 /* -----------------------------------------------------------------------------
141 * Looking up
142 * -------------------------------------------------------------------------- */
143
144 /*
145 * get at the real stuff...remove indirections.
146 */
147 static StgClosure*
148 removeIndirections (StgClosure* p)
149 {
150 StgClosure* q;
151
152 while (1)
153 {
154 q = UNTAG_CLOSURE(p);
155
156 switch (get_itbl(q)->type) {
157 case IND:
158 case IND_STATIC:
159 p = ((StgInd *)q)->indirectee;
160 continue;
161
162 case BLACKHOLE:
163 p = ((StgInd *)q)->indirectee;
164 if (GET_CLOSURE_TAG(p) != 0) {
165 continue;
166 } else {
167 break;
168 }
169
170 default:
171 break;
172 }
173 return p;
174 }
175 }
176
177 StgWord
178 lookupStableName (StgPtr p)
179 {
180 stableNameLock();
181
182 if (stable_name_free == NULL) {
183 enlargeStableNameTable();
184 }
185
186 /* removing indirections increases the likelihood
187 * of finding a match in the stable name hash table.
188 */
189 p = (StgPtr)removeIndirections((StgClosure*)p);
190
191 // register the untagged pointer. This just makes things simpler.
192 p = (StgPtr)UNTAG_CLOSURE((StgClosure*)p);
193
194 StgWord sn = (StgWord)lookupHashTable(addrToStableHash,(W_)p);
195
196 if (sn != 0) {
197 ASSERT(stable_name_table[sn].addr == p);
198 debugTrace(DEBUG_stable, "cached stable name %ld at %p",sn,p);
199 stableNameUnlock();
200 return sn;
201 }
202
203 sn = stable_name_free - stable_name_table;
204 stable_name_free = (snEntry*)(stable_name_free->addr);
205 stable_name_table[sn].addr = p;
206 stable_name_table[sn].sn_obj = NULL;
207 /* debugTrace(DEBUG_stable, "new stable name %d at %p\n",sn,p); */
208
209 /* add the new stable name to the hash table */
210 insertHashTable(addrToStableHash, (W_)p, (void *)sn);
211
212 stableNameUnlock();
213
214 return sn;
215 }
216
217 /* -----------------------------------------------------------------------------
218 * Remember old stable name addresses
219 * -------------------------------------------------------------------------- */
220
221 #define FOR_EACH_STABLE_NAME(p, CODE) \
222 do { \
223 snEntry *p; \
224 snEntry *__end_ptr = &stable_name_table[SNT_size]; \
225 for (p = stable_name_table + 1; p < __end_ptr; p++) { \
226 /* Internal pointers are free slots. */ \
227 /* If p->addr == NULL, it's a */ \
228 /* stable name where the object has been GC'd, but the */ \
229 /* StableName object (sn_obj) is still alive. */ \
230 if ((p->addr < (P_)stable_name_table || \
231 p->addr >= (P_)__end_ptr)) \
232 { \
233 /* NOTE: There is an ambiguity here if p->addr == NULL */ \
234 /* it is either the last item in the free list or it */ \
235 /* is a stable name whose pointee died. sn_obj == NULL */ \
236 /* disambiguates as last free list item. */ \
237 do { CODE } while(0); \
238 } \
239 } \
240 } while(0)
241
242 void
243 rememberOldStableNameAddresses(void)
244 {
245 /* TODO: Only if !full GC */
246 FOR_EACH_STABLE_NAME(p, p->old = p->addr;);
247 }
248
249 /* -----------------------------------------------------------------------------
250 * Thread the stable name table for compacting GC.
251 *
252 * Here we must call the supplied evac function for each pointer into
253 * the heap from the stable name table, because the compacting
254 * collector may move the object it points to.
255 * -------------------------------------------------------------------------- */
256
257 void
258 threadStableNameTable( evac_fn evac, void *user )
259 {
260 FOR_EACH_STABLE_NAME(p, {
261 if (p->sn_obj != NULL) {
262 evac(user, (StgClosure **)&p->sn_obj);
263 }
264 if (p->addr != NULL) {
265 evac(user, (StgClosure **)&p->addr);
266 }
267 });
268 }
269
270 /* -----------------------------------------------------------------------------
271 * Garbage collect any dead entries in the stable name table.
272 *
273 * A dead entry has:
274 *
275 * - a zero reference count
276 * - a dead sn_obj
277 *
278 * Both of these conditions must be true in order to re-use the stable
279 * name table entry. We can re-use stable name table entries for live
280 * heap objects, as long as the program has no StableName objects that
281 * refer to the entry.
282 * -------------------------------------------------------------------------- */
283
284 void
285 gcStableNameTable( void )
286 {
287 FOR_EACH_STABLE_NAME(
288 p, {
289 // FOR_EACH_STABLE_NAME traverses free entries too, so
290 // check sn_obj
291 if (p->sn_obj != NULL) {
292 // Update the pointer to the StableName object, if there is one
293 p->sn_obj = isAlive(p->sn_obj);
294 if (p->sn_obj == NULL) {
295 // StableName object died
296 debugTrace(DEBUG_stable, "GC'd StableName %ld (addr=%p)",
297 (long)(p - stable_name_table), p->addr);
298 freeSnEntry(p);
299 } else if (p->addr != NULL) {
300 // sn_obj is alive, update pointee
301 p->addr = (StgPtr)isAlive((StgClosure *)p->addr);
302 if (p->addr == NULL) {
303 // Pointee died
304 debugTrace(DEBUG_stable, "GC'd pointee %ld",
305 (long)(p - stable_name_table));
306 }
307 }
308 }
309 });
310 }
311
312 /* -----------------------------------------------------------------------------
313 * Update the StableName hash table
314 *
315 * The boolean argument 'full' indicates that a major collection is
316 * being done, so we might as well throw away the hash table and build
317 * a new one. For a minor collection, we just re-hash the elements
318 * that changed.
319 * -------------------------------------------------------------------------- */
320
321 void
322 updateStableNameTable(bool full)
323 {
324 if (full && addrToStableHash != NULL && 0 != keyCountHashTable(addrToStableHash)) {
325 freeHashTable(addrToStableHash,NULL);
326 addrToStableHash = allocHashTable();
327 }
328
329 if(full) {
330 FOR_EACH_STABLE_NAME(
331 p, {
332 if (p->addr != NULL) {
333 // Target still alive, Re-hash this stable name
334 insertHashTable(addrToStableHash, (W_)p->addr, (void *)(p - stable_name_table));
335 }
336 });
337 } else {
338 FOR_EACH_STABLE_NAME(
339 p, {
340 if (p->addr != p->old) {
341 removeHashTable(addrToStableHash, (W_)p->old, NULL);
342 /* Movement happened: */
343 if (p->addr != NULL) {
344 insertHashTable(addrToStableHash, (W_)p->addr, (void *)(p - stable_name_table));
345 }
346 }
347 });
348 }
349 }