implemented Setup.hs to build boehm cpp libs and install them;
[hs-boehmgc.git] / gc-7.2 / backgraph.c
1 /*
2  * Copyright (c) 2001 by Hewlett-Packard Company. All rights reserved.
3  *
4  * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED
5  * OR IMPLIED.  ANY USE IS AT YOUR OWN RISK.
6  *
7  * Permission is hereby granted to use or copy this program
8  * for any purpose,  provided the above notices are retained on all copies.
9  * Permission to modify the code and to distribute modified code is granted,
10  * provided the above notices are retained, and a notice that the code was
11  * modified is included with the above copyright notice.
12  *
13  */
14
15 #include "private/dbg_mlc.h"
16
17 /*
18  * This implements a full, though not well-tuned, representation of the
19  * backwards points-to graph.  This is used to test for non-GC-robust
20  * data structures; the code is not used during normal garbage collection.
21  *
22  * One restriction is that we drop all back-edges from nodes with very
23  * high in-degree, and simply add them add them to a list of such
24  * nodes.  They are then treated as permanent roots.  Id this by itself
25  * doesn't introduce a space leak, then such nodes can't contribute to
26  * a growing space leak.
27  */
28
29 #ifdef MAKE_BACK_GRAPH
30
31 #define MAX_IN  10      /* Maximum in-degree we handle directly */
32
33 /* #include <unistd.h> */
34
35 #if !defined(DBG_HDRS_ALL) || (ALIGNMENT != CPP_WORDSZ/8) /* || !defined(UNIX_LIKE) */
36 # error The configuration does not support MAKE_BACK_GRAPH
37 #endif
38
39 /* We store single back pointers directly in the object's oh_bg_ptr field. */
40 /* If there is more than one ptr to an object, we store q | FLAG_MANY,     */
41 /* where q is a pointer to a back_edges object.                            */
42 /* Every once in a while we use a back_edges object even for a single      */
43 /* pointer, since we need the other fields in the back_edges structure to  */
44 /* be present in some fraction of the objects.  Otherwise we get serious   */
45 /* performance issues.                                                     */
46 #define FLAG_MANY 2
47
48 typedef struct back_edges_struct {
49   word n_edges; /* Number of edges, including those in continuation     */
50                 /* structures.                                          */
51   unsigned short flags;
52 #       define RETAIN 1 /* Directly points to a reachable object;       */
53                         /* retain for next GC.                          */
54   unsigned short height_gc_no;
55                 /* If height > 0, then the GC_gc_no value when it       */
56                 /* was computed.  If it was computed this cycle, then   */
57                 /* it is current.  If it was computed during the        */
58                 /* last cycle, then it represents the old height,       */
59                 /* which is only saved for live objects referenced by   */
60                 /* dead ones.  This may grow due to refs from newly     */
61                 /* dead objects.                                        */
62   signed_word height;
63                 /* Longest path through unreachable nodes to this node  */
64                 /* that we found using depth first search.              */
65
66 #   define HEIGHT_UNKNOWN ((signed_word)(-2))
67 #   define HEIGHT_IN_PROGRESS ((signed_word)(-1))
68   ptr_t edges[MAX_IN];
69   struct back_edges_struct *cont;
70                 /* Pointer to continuation structure; we use only the   */
71                 /* edges field in the continuation.                     */
72                 /* also used as free list link.                         */
73 } back_edges;
74
75 /* Allocate a new back edge structure.  Should be more sophisticated    */
76 /* if this were production code.                                        */
77 #define MAX_BACK_EDGE_STRUCTS 100000
78 static back_edges *back_edge_space = 0;
79 STATIC int GC_n_back_edge_structs = 0;
80                                 /* Serves as pointer to never used      */
81                                 /* back_edges space.                    */
82 static back_edges *avail_back_edges = 0;
83                                 /* Pointer to free list of deallocated  */
84                                 /* back_edges structures.               */
85
86 static back_edges * new_back_edges(void)
87 {
88   if (0 == back_edge_space) {
89     back_edge_space = (back_edges *)
90                         GET_MEM(MAX_BACK_EDGE_STRUCTS*sizeof(back_edges));
91     GC_add_to_our_memory((ptr_t)back_edge_space,
92                          MAX_BACK_EDGE_STRUCTS*sizeof(back_edges));
93   }
94   if (0 != avail_back_edges) {
95     back_edges * result = avail_back_edges;
96     avail_back_edges = result -> cont;
97     result -> cont = 0;
98     return result;
99   }
100   if (GC_n_back_edge_structs >= MAX_BACK_EDGE_STRUCTS - 1) {
101     ABORT("Needed too much space for back edges: adjust "
102           "MAX_BACK_EDGE_STRUCTS");
103   }
104   return back_edge_space + (GC_n_back_edge_structs++);
105 }
106
107 /* Deallocate p and its associated continuation structures.     */
108 static void deallocate_back_edges(back_edges *p)
109 {
110    back_edges *last = p;
111
112    while (0 != last -> cont) last = last -> cont;
113    last -> cont = avail_back_edges;
114    avail_back_edges = p;
115 }
116
117 /* Table of objects that are currently on the depth-first search        */
118 /* stack.  Only objects with in-degree one are in this table.           */
119 /* Other objects are identified using HEIGHT_IN_PROGRESS.               */
120 /* FIXME: This data structure NEEDS IMPROVEMENT.                        */
121 #define INITIAL_IN_PROGRESS 10000
122 static ptr_t * in_progress_space = 0;
123 static size_t in_progress_size = 0;
124 static size_t n_in_progress = 0;
125
126 static void push_in_progress(ptr_t p)
127 {
128   if (n_in_progress >= in_progress_size) {
129     if (in_progress_size == 0) {
130       in_progress_size = INITIAL_IN_PROGRESS;
131       in_progress_space = (ptr_t *)GET_MEM(in_progress_size * sizeof(ptr_t));
132       GC_add_to_our_memory((ptr_t)in_progress_space,
133                            in_progress_size * sizeof(ptr_t));
134     } else {
135       ptr_t * new_in_progress_space;
136       in_progress_size *= 2;
137       new_in_progress_space = (ptr_t *)
138                                 GET_MEM(in_progress_size * sizeof(ptr_t));
139       GC_add_to_our_memory((ptr_t)new_in_progress_space,
140                            in_progress_size * sizeof(ptr_t));
141       BCOPY(in_progress_space, new_in_progress_space,
142             n_in_progress * sizeof(ptr_t));
143       in_progress_space = new_in_progress_space;
144       /* FIXME: This just drops the old space.  */
145     }
146   }
147   if (in_progress_space == 0)
148       ABORT("MAKE_BACK_GRAPH: Out of in-progress space: "
149             "Huge linear data structure?");
150   in_progress_space[n_in_progress++] = p;
151 }
152
153 static GC_bool is_in_progress(ptr_t p)
154 {
155   size_t i;
156   for (i = 0; i < n_in_progress; ++i) {
157     if (in_progress_space[i] == p) return TRUE;
158   }
159   return FALSE;
160 }
161
162 GC_INLINE void pop_in_progress(ptr_t p)
163 {
164   --n_in_progress;
165   GC_ASSERT(in_progress_space[n_in_progress] == p);
166 }
167
168 #define GET_OH_BG_PTR(p) \
169                 (ptr_t)GC_REVEAL_POINTER(((oh *)(p)) -> oh_bg_ptr)
170 #define SET_OH_BG_PTR(p,q) (((oh *)(p)) -> oh_bg_ptr = GC_HIDE_POINTER(q))
171
172 /* Execute s once for each predecessor q of p in the points-to graph.   */
173 /* s should be a bracketed statement.  We declare q.                    */
174 #define FOR_EACH_PRED(q, p, s) \
175   { \
176     ptr_t q = GET_OH_BG_PTR(p); \
177     if (!((word)q & FLAG_MANY)) { \
178       if (q && !((word)q & 1)) s \
179               /* !((word)q & 1) checks for a misinterpreted freelist link */ \
180     } else { \
181       back_edges *orig_be_ = (back_edges *)((word)q & ~FLAG_MANY); \
182       back_edges *be_ = orig_be_; \
183       int local_; \
184       word total_; \
185       word n_edges_ = be_ -> n_edges; \
186       for (total_ = 0, local_ = 0; total_ < n_edges_; ++local_, ++total_) { \
187           if (local_ == MAX_IN) { \
188               be_ = be_ -> cont; \
189               local_ = 0; \
190           } \
191           q = be_ -> edges[local_]; s \
192       } \
193     } \
194   }
195
196 /* Ensure that p has a back_edges structure associated with it. */
197 static void ensure_struct(ptr_t p)
198 {
199   ptr_t old_back_ptr = GET_OH_BG_PTR(p);
200
201   if (!((word)old_back_ptr & FLAG_MANY)) {
202     back_edges *be = new_back_edges();
203     be -> flags = 0;
204     if (0 == old_back_ptr) {
205       be -> n_edges = 0;
206     } else {
207       be -> n_edges = 1;
208       be -> edges[0] = old_back_ptr;
209     }
210     be -> height = HEIGHT_UNKNOWN;
211     be -> height_gc_no = (unsigned short)(GC_gc_no - 1);
212     GC_ASSERT(be >= back_edge_space);
213     SET_OH_BG_PTR(p, (word)be | FLAG_MANY);
214   }
215 }
216
217 /* Add the (forward) edge from p to q to the backward graph.  Both p    */
218 /* q are pointers to the object base, i.e. pointers to an oh.           */
219 static void add_edge(ptr_t p, ptr_t q)
220 {
221     ptr_t old_back_ptr = GET_OH_BG_PTR(q);
222     back_edges * be, *be_cont;
223     word i;
224     static unsigned random_number = 13;
225 #   define GOT_LUCKY_NUMBER (((++random_number) & 0x7f) == 0)
226       /* A not very random number we use to occasionally allocate a     */
227       /* back_edges structure even for a single backward edge.  This    */
228       /* prevents us from repeatedly tracing back through very long     */
229       /* chains, since we will have some place to store height and      */
230       /* in_progress flags along the way.                               */
231
232     GC_ASSERT(p == GC_base(p) && q == GC_base(q));
233     if (!GC_HAS_DEBUG_INFO(q) || !GC_HAS_DEBUG_INFO(p)) {
234       /* This is really a misinterpreted free list link, since we saw   */
235       /* a pointer to a free list.  Don't overwrite it!                 */
236       return;
237     }
238     if (0 == old_back_ptr) {
239         SET_OH_BG_PTR(q, p);
240         if (GOT_LUCKY_NUMBER) ensure_struct(q);
241         return;
242     }
243     /* Check whether it was already in the list of predecessors. */
244       FOR_EACH_PRED(pred, q, { if (p == pred) return; });
245     ensure_struct(q);
246     old_back_ptr = GET_OH_BG_PTR(q);
247     be = (back_edges *)((word)old_back_ptr & ~FLAG_MANY);
248     for (i = be -> n_edges, be_cont = be; i > MAX_IN; i -= MAX_IN)
249         be_cont = be_cont -> cont;
250     if (i == MAX_IN) {
251         be_cont -> cont = new_back_edges();
252         be_cont = be_cont -> cont;
253         i = 0;
254     }
255     be_cont -> edges[i] = p;
256     be -> n_edges++;
257 #   ifdef DEBUG_PRINT_BIG_N_EDGES
258       if (GC_print_stats == VERBOSE && be -> n_edges == 100) {
259         GC_err_printf("The following object has big in-degree:\n");
260         GC_print_heap_obj(q);
261       }
262 #   endif
263 }
264
265 typedef void (*per_object_func)(ptr_t p, size_t n_bytes, word gc_descr);
266
267 static void per_object_helper(struct hblk *h, word fn)
268 {
269   hdr * hhdr = HDR(h);
270   size_t sz = hhdr -> hb_sz;
271   word descr = hhdr -> hb_descr;
272   per_object_func f = (per_object_func)fn;
273   int i = 0;
274
275   do {
276     f((ptr_t)(h -> hb_body + i), sz, descr);
277     i += (int)sz;
278   } while ((word)i + sz <= BYTES_TO_WORDS(HBLKSIZE));
279 }
280
281 GC_INLINE void GC_apply_to_each_object(per_object_func f)
282 {
283   GC_apply_to_all_blocks(per_object_helper, (word)f);
284 }
285
286 /*ARGSUSED*/
287 static void reset_back_edge(ptr_t p, size_t n_bytes, word gc_descr)
288 {
289   /* Skip any free list links, or dropped blocks */
290   if (GC_HAS_DEBUG_INFO(p)) {
291     ptr_t old_back_ptr = GET_OH_BG_PTR(p);
292     if ((word)old_back_ptr & FLAG_MANY) {
293       back_edges *be = (back_edges *)((word)old_back_ptr & ~FLAG_MANY);
294       if (!(be -> flags & RETAIN)) {
295         deallocate_back_edges(be);
296         SET_OH_BG_PTR(p, 0);
297       } else {
298
299         GC_ASSERT(GC_is_marked(p));
300
301         /* Back edges may point to objects that will not be retained.   */
302         /* Delete them for now, but remember the height.                */
303         /* Some will be added back at next GC.                          */
304           be -> n_edges = 0;
305           if (0 != be -> cont) {
306             deallocate_back_edges(be -> cont);
307             be -> cont = 0;
308           }
309
310         GC_ASSERT(GC_is_marked(p));
311
312         /* We only retain things for one GC cycle at a time.            */
313           be -> flags &= ~RETAIN;
314       }
315     } else /* Simple back pointer */ {
316       /* Clear to avoid dangling pointer. */
317       SET_OH_BG_PTR(p, 0);
318     }
319   }
320 }
321
322 static void add_back_edges(ptr_t p, size_t n_bytes, word gc_descr)
323 {
324   word *currentp = (word *)(p + sizeof(oh));
325
326   /* For now, fix up non-length descriptors conservatively.     */
327     if((gc_descr & GC_DS_TAGS) != GC_DS_LENGTH) {
328       gc_descr = n_bytes;
329     }
330   while (currentp < (word *)(p + gc_descr)) {
331     word current = *currentp++;
332     FIXUP_POINTER(current);
333     if (current >= (word)GC_least_plausible_heap_addr &&
334         current <= (word)GC_greatest_plausible_heap_addr) {
335        ptr_t target = GC_base((void *)current);
336        if (0 != target) {
337          add_edge(p, target);
338        }
339     }
340   }
341 }
342
343 /* Rebuild the representation of the backward reachability graph.       */
344 /* Does not examine mark bits.  Can be called before GC.                */
345 GC_INNER void GC_build_back_graph(void)
346 {
347   GC_apply_to_each_object(add_back_edges);
348 }
349
350 /* Return an approximation to the length of the longest simple path     */
351 /* through unreachable objects to p.  We refer to this as the height    */
352 /* of p.                                                                */
353 static word backwards_height(ptr_t p)
354 {
355   word result;
356   ptr_t back_ptr = GET_OH_BG_PTR(p);
357   back_edges *be;
358
359   if (0 == back_ptr) return 1;
360   if (!((word)back_ptr & FLAG_MANY)) {
361     if (is_in_progress(p)) return 0; /* DFS back edge, i.e. we followed */
362                                      /* an edge to an object already    */
363                                      /* on our stack: ignore            */
364     push_in_progress(p);
365     result = backwards_height(back_ptr)+1;
366     pop_in_progress(p);
367     return result;
368   }
369   be = (back_edges *)((word)back_ptr & ~FLAG_MANY);
370   if (be -> height >= 0 && be -> height_gc_no == (unsigned short)GC_gc_no)
371       return be -> height;
372   /* Ignore back edges in DFS */
373     if (be -> height == HEIGHT_IN_PROGRESS) return 0;
374   result = (be -> height > 0? be -> height : 1);
375   be -> height = HEIGHT_IN_PROGRESS;
376   FOR_EACH_PRED(q, p, {
377     word this_height;
378     if (GC_is_marked(q) && !(FLAG_MANY & (word)GET_OH_BG_PTR(p))) {
379       if (GC_print_stats)
380           GC_log_printf("Found bogus pointer from %p to %p\n", q, p);
381         /* Reachable object "points to" unreachable one.                */
382         /* Could be caused by our lax treatment of GC descriptors.      */
383       this_height = 1;
384     } else {
385         this_height = backwards_height(q);
386     }
387     if (this_height >= result) result = this_height + 1;
388   });
389   be -> height = result;
390   be -> height_gc_no = (unsigned short)GC_gc_no;
391   return result;
392 }
393
394 STATIC word GC_max_height = 0;
395 STATIC ptr_t GC_deepest_obj = NULL;
396
397 /* Compute the maximum height of every unreachable predecessor p of a   */
398 /* reachable object.  Arrange to save the heights of all such objects p */
399 /* so that they can be used in calculating the height of objects in the */
400 /* next GC.                                                             */
401 /* Set GC_max_height to be the maximum height we encounter, and         */
402 /* GC_deepest_obj to be the corresponding object.                       */
403 /*ARGSUSED*/
404 static void update_max_height(ptr_t p, size_t n_bytes, word gc_descr)
405 {
406   if (GC_is_marked(p) && GC_HAS_DEBUG_INFO(p)) {
407     word p_height = 0;
408     ptr_t p_deepest_obj = 0;
409     ptr_t back_ptr;
410     back_edges *be = 0;
411
412     /* If we remembered a height last time, use it as a minimum.        */
413     /* It may have increased due to newly unreachable chains pointing   */
414     /* to p, but it can't have decreased.                               */
415     back_ptr = GET_OH_BG_PTR(p);
416     if (0 != back_ptr && ((word)back_ptr & FLAG_MANY)) {
417       be = (back_edges *)((word)back_ptr & ~FLAG_MANY);
418       if (be -> height != HEIGHT_UNKNOWN) p_height = be -> height;
419     }
420     FOR_EACH_PRED(q, p, {
421       if (!GC_is_marked(q) && GC_HAS_DEBUG_INFO(q)) {
422         word q_height;
423
424         q_height = backwards_height(q);
425         if (q_height > p_height) {
426           p_height = q_height;
427           p_deepest_obj = q;
428         }
429       }
430     });
431     if (p_height > 0) {
432       /* Remember the height for next time. */
433         if (be == 0) {
434           ensure_struct(p);
435           back_ptr = GET_OH_BG_PTR(p);
436           be = (back_edges *)((word)back_ptr & ~FLAG_MANY);
437         }
438         be -> flags |= RETAIN;
439         be -> height = p_height;
440         be -> height_gc_no = (unsigned short)GC_gc_no;
441     }
442     if (p_height > GC_max_height) {
443         GC_max_height = p_height;
444         GC_deepest_obj = p_deepest_obj;
445     }
446   }
447 }
448
449 STATIC word GC_max_max_height = 0;
450
451 GC_INNER void GC_traverse_back_graph(void)
452 {
453   GC_max_height = 0;
454   GC_apply_to_each_object(update_max_height);
455   if (0 != GC_deepest_obj)
456     GC_set_mark_bit(GC_deepest_obj);  /* Keep it until we can print it. */
457 }
458
459 void GC_print_back_graph_stats(void)
460 {
461   GC_printf("Maximum backwards height of reachable objects at GC %lu is %ld\n",
462             (unsigned long) GC_gc_no, (unsigned long)GC_max_height);
463   if (GC_max_height > GC_max_max_height) {
464     GC_max_max_height = GC_max_height;
465     GC_printf("The following unreachable object is last in a longest chain "
466               "of unreachable objects:\n");
467     GC_print_heap_obj(GC_deepest_obj);
468   }
469   if (GC_print_stats) {
470     GC_log_printf("Needed max total of %d back-edge structs\n",
471                   GC_n_back_edge_structs);
472   }
473   GC_apply_to_each_object(reset_back_edge);
474   GC_deepest_obj = 0;
475 }
476
477 #endif /* MAKE_BACK_GRAPH */