1 /*  gc.c -- simple mark&sweep garbage collector               */
2 /*  Copyright (c) 2009-2015 Alex Shinn.  All rights reserved. */
3 /*  BSD-style license: http://synthcode.com/license.txt       */
4 
5 #if ! SEXP_USE_BOEHM && ! SEXP_USE_MALLOC
6 
7 #include "chibi/sexp.h"
8 
9 #if SEXP_USE_TIME_GC
10 #include <sys/resource.h>
11 #endif
12 
13 #if SEXP_USE_MMAP_GC
14 #include <sys/mman.h>
15 #endif
16 
17 #define SEXP_BANNER(x) ("**************** GC "x"\n")
18 
19 #define SEXP_MINIMUM_OBJECT_SIZE (sexp_heap_align(1))
20 
21 #if SEXP_USE_GLOBAL_HEAP
22 sexp_heap sexp_global_heap;
23 #endif
24 
25 #if SEXP_USE_CONSERVATIVE_GC
26 static sexp* stack_base;
27 #endif
28 
29 #if SEXP_USE_DEBUG_GC
30 #define sexp_debug_printf(fmt, ...) fprintf(stderr, SEXP_BANNER(fmt),__VA_ARGS__)
31 #else
32 #define sexp_debug_printf(fmt, ...)
33 #endif
34 
sexp_heap_last(sexp_heap h)35 static sexp_heap sexp_heap_last (sexp_heap h) {
36   while (h->next) h = h->next;
37   return h;
38 }
39 
40 #if !SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
sexp_heap_total_size(sexp_heap h)41 static size_t sexp_heap_total_size (sexp_heap h) {
42   size_t total_size = 0;
43   for (; h; h=h->next)
44     total_size += h->size;
45   return total_size;
46 }
47 #endif
48 
49 #if ! SEXP_USE_GLOBAL_HEAP
50 #if SEXP_USE_DEBUG_GC
sexp_debug_heap_stats(sexp_heap heap)51 void sexp_debug_heap_stats (sexp_heap heap) {
52   sexp_free_list ls;
53   size_t available = 0;
54   for (ls=heap->free_list; ls; ls=ls->next)
55     available += ls->size;
56 #if SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
57   sexp_debug_printf("free heap: %p (chunk size: %lu): %ld / %ld used (%.2f%%)", heap, heap->chunk_size, heap->size - available, heap->size, 100*(heap->size - available) / (float)heap->size);
58 #else
59   sexp_debug_printf("free heap: %p: %ld / %ld used (%.2f%%)", heap, heap->size - available, heap->size, 100*(heap->size - available) / (float)heap->size);
60 #endif
61   if (heap->next)
62     sexp_debug_heap_stats(heap->next);
63 }
64 #endif
65 
66 #if SEXP_USE_TRACK_ALLOC_TIMES
sexp_debug_alloc_times(sexp ctx)67 void sexp_debug_alloc_times(sexp ctx) {
68   double mean = (double) sexp_context_alloc_usecs(ctx) / sexp_context_alloc_count(ctx);
69   double var = (double) sexp_context_alloc_usecs_sq(ctx) / sexp_context_alloc_count(ctx) - mean*mean;
70   fprintf(stderr, SEXP_BANNER("alloc: mean: %0.3lfμs var: %0.3lfμs (%ld times)"), mean, var, sexp_context_alloc_count(ctx));
71 }
72 #endif
73 
74 #if SEXP_USE_TRACK_ALLOC_SIZES
sexp_debug_alloc_sizes(sexp ctx)75 void sexp_debug_alloc_sizes(sexp ctx) {
76   int i;
77   fprintf(stderr, "alloc size histogram: {");
78   for (i=0; i<SEXP_ALLOC_HISTOGRAM_BUCKETS; ++i) {
79     if ((i+1)*sexp_heap_align(1)<100 || sexp_context_alloc_histogram(ctx)[i]>0)
80       fprintf(stderr, "  %ld:%ld", (i+1)*sexp_heap_align(1), sexp_context_alloc_histogram(ctx)[i]);
81   }
82   fprintf(stderr, "}\n");
83 }
84 #endif
85 
sexp_free_heap(sexp_heap heap)86 void sexp_free_heap (sexp_heap heap) {
87 #if SEXP_USE_MMAP_GC
88   munmap(heap, sexp_heap_pad_size(heap->size));
89 #else
90   free(heap);
91 #endif
92 }
93 #endif
94 
95 #if SEXP_USE_LIMITED_MALLOC
96 static sexp_sint_t allocated_bytes=0, max_allocated_bytes=-1;
sexp_malloc(size_t size)97 void* sexp_malloc(size_t size) {
98   char* max_alloc;
99   void* res;
100   if (max_allocated_bytes < 0) {
101     max_alloc = getenv("CHIBI_MAX_ALLOC");
102     max_allocated_bytes = max_alloc ? atoi(max_alloc) : 8192000; /* 8MB */
103   }
104   if (max_allocated_bytes > 0 && allocated_bytes + size > max_allocated_bytes)
105     return NULL;
106   if (!(res = malloc(size))) return NULL;
107   allocated_bytes += size;
108   return res;
109 }
110 /* TODO: subtract freed memory from max_allocated_bytes */
sexp_free(void * ptr)111 void sexp_free(void* ptr) {
112   free(ptr);
113 }
114 #endif
115 
sexp_preserve_object(sexp ctx,sexp x)116 void sexp_preserve_object(sexp ctx, sexp x) {
117   sexp_global(ctx, SEXP_G_PRESERVATIVES) = sexp_cons(ctx, x, sexp_global(ctx, SEXP_G_PRESERVATIVES));
118 }
119 
sexp_release_object(sexp ctx,sexp x)120 void sexp_release_object(sexp ctx, sexp x) {
121   sexp ls1, ls2;
122   for (ls1=NULL, ls2=sexp_global(ctx, SEXP_G_PRESERVATIVES); sexp_pairp(ls2);
123        ls1=ls2, ls2=sexp_cdr(ls2))
124     if (sexp_car(ls2) == x) {
125       if (ls1) sexp_cdr(ls1) = sexp_cdr(ls2);
126       else sexp_global(ctx, SEXP_G_PRESERVATIVES) = sexp_cdr(ls2);
127       break;
128     }
129 }
130 
sexp_allocated_bytes(sexp ctx,sexp x)131 SEXP_API sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) {
132   sexp_uint_t res;
133   sexp t;
134   if (!sexp_pointerp(x) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx)))
135     return sexp_heap_align(1);
136   t = sexp_object_type(ctx, x);
137   res = sexp_type_size_of_object(t, x) + SEXP_GC_PAD;
138 #if SEXP_USE_DEBUG_GC
139   if (res == 0) {
140     fprintf(stderr, SEXP_BANNER("%p zero-size object: %p (type tag: %d)"), ctx, x, sexp_pointer_tag(x));
141     return 1;
142   }
143 #endif
144   return res;
145 }
146 
147 #if SEXP_USE_SAFE_GC_MARK
148 
149 #if SEXP_USE_DEBUG_GC > 2
sexp_valid_heap_position(sexp ctx,sexp_heap h,sexp x)150 int sexp_valid_heap_position(sexp ctx, sexp_heap h, sexp x) {
151   sexp p = sexp_heap_first_block(h), end = sexp_heap_end(h);
152   sexp_free_list q = h->free_list, r;
153   while (p < end) {
154     for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
155       ;
156     if ((char*)r == (char*)p) {
157       p = (sexp) (((char*)p) + r->size);
158       continue;
159     }
160     if (p == x) {
161       return 1;
162     } else if (p > x) {
163       fprintf(stderr, SEXP_BANNER("bad heap position: %p free: %p-%p : %p-%p"),
164               x, q, ((char*)q)+q->size, r, ((char*)r)+r->size);
165       return 0;
166     }
167     p = (sexp) (((char*)p)+sexp_heap_align(sexp_allocated_bytes(ctx, p)));
168   }
169   fprintf(stderr, SEXP_BANNER("bad heap position: %p heap: %p-%p"), x, h, end);
170   return 0;
171 }
172 #else
173 #define sexp_valid_heap_position(ctx, h, x) 1
174 #endif
175 
sexp_in_heap_p(sexp ctx,sexp x)176 int sexp_in_heap_p(sexp ctx, sexp x) {
177   sexp_heap h;
178   if ((sexp_uint_t)x & (sexp_heap_align(1)-1)) {
179     fprintf(stderr, SEXP_BANNER("invalid heap alignment: %p"), x);
180     return 0;
181   }
182   for (h=sexp_context_heap(ctx); h; h=h->next)
183     if (((sexp)h < x) && (x < (sexp)(h->data + h->size)))
184       return sexp_valid_heap_position(ctx, h, x);
185   fprintf(stderr, SEXP_BANNER("invalid object outside heap: %p"), x);
186   return 0;
187 }
188 #endif
189 
190 #if SEXP_USE_DEBUG_GC > 1
sexp_valid_object_type_p(sexp ctx,sexp x)191 int sexp_valid_object_type_p (sexp ctx, sexp x) {
192   if (sexp_pointer_tag(x)<=0 || sexp_pointer_tag(x)>sexp_context_num_types(ctx)){
193     fprintf(stderr, SEXP_BANNER("%p mark: bad object at %p: tag: %d"),
194             ctx, x, sexp_pointer_tag(x));
195     return 0;
196   }
197   return 1;
198 }
199 #else
200 #define sexp_valid_object_type_p(ctx, x) 1
201 #endif
202 
203 #if SEXP_USE_HEADER_MAGIC
sexp_valid_header_magic_p(sexp ctx,sexp x)204 int sexp_valid_header_magic_p (sexp ctx, sexp x) {
205   if (sexp_pointer_magic(x)  != SEXP_POINTER_MAGIC
206       && sexp_pointer_tag(x) != SEXP_TYPE && sexp_pointer_tag(x) != SEXP_OPCODE
207       && sexp_pointer_tag(x) != SEXP_CORE && sexp_pointer_tag(x) != SEXP_STACK) {
208     fprintf(stderr, SEXP_BANNER("%p mark: bad magic at %p: %x"),
209             ctx, x, sexp_pointer_magic(x));
210     return 0;
211   }
212   return 1;
213 }
214 #else
215 #define sexp_valid_header_magic_p(ctx, x) 1
216 #endif
217 
218 #if SEXP_DEBUG_GC > 1 || SEXP_USE_SAFE_GC_MARK || SEXP_USE_HEADER_MAGIC
sexp_valid_object_p(sexp ctx,sexp x)219 int sexp_valid_object_p (sexp ctx, sexp x) {
220   return sexp_in_heap_p(ctx, x) && sexp_valid_object_type_p(ctx, x)
221     && sexp_valid_header_magic_p(ctx, x);
222 }
223 #define sexp_gc_pass_ctx(x) x,
224 #else
225 #define sexp_gc_pass_ctx(x)
226 #endif
227 
sexp_mark_stack_push(sexp ctx,sexp * start,sexp * end)228 static void sexp_mark_stack_push (sexp ctx, sexp *start, sexp *end) {
229   struct sexp_mark_stack_ptr_t *stack = sexp_context_mark_stack(ctx);
230   struct sexp_mark_stack_ptr_t **ptr = &sexp_context_mark_stack_ptr(ctx);
231   struct sexp_mark_stack_ptr_t *old = *ptr;
232 
233   if (old == NULL) {
234     *ptr = stack;
235   } else if (old >= stack && old + 1 < stack + SEXP_MARK_STACK_COUNT) {
236     (*ptr)++;
237   } else {
238     *ptr = malloc(sizeof(**ptr));
239   }
240 
241   (*ptr)->start = start;
242   (*ptr)->end = end;
243   (*ptr)->prev = old;
244 }
245 
sexp_mark_stack_pop(sexp ctx)246 static void sexp_mark_stack_pop (sexp ctx) {
247   struct sexp_mark_stack_ptr_t *stack = sexp_context_mark_stack(ctx);
248   struct sexp_mark_stack_ptr_t *old = sexp_context_mark_stack_ptr(ctx);
249 
250   sexp_context_mark_stack_ptr(ctx) = old->prev;
251   if (!(old >= stack && old < stack + SEXP_MARK_STACK_COUNT)) {
252     free(old);
253   }
254 }
255 
sexp_mark_one(sexp ctx,sexp * types,sexp x)256 static void sexp_mark_one (sexp ctx, sexp* types, sexp x) {
257   sexp_sint_t len;
258   sexp t, *p, *q;
259   struct sexp_gc_var_t *saves;
260  loop:
261   if (!x || !sexp_pointerp(x) || !sexp_valid_object_p(ctx, x) || sexp_markedp(x))
262     return;
263   sexp_markedp(x) = 1;
264   if (sexp_contextp(x)) {
265     for (saves=sexp_context_saves(x); saves; saves=saves->next)
266       if (saves->var) sexp_mark_one(ctx, types, *(saves->var));
267   }
268   t = types[sexp_pointer_tag(x)];
269   len = sexp_type_num_slots_of_object(t, x) - 1;
270   if (len >= 0) {
271     p = (sexp*) (((char*)x) + sexp_type_field_base(t));
272     q = p + len;
273     while (p < q && (*q && sexp_pointerp(*q) ? sexp_markedp(*q) : 1))
274       q--;                      /* skip trailing immediates */
275     while (p < q && *q == q[-1])
276       q--;                      /* skip trailing duplicates */
277     if (p < q) {
278       sexp_mark_stack_push(ctx, p, q);
279     }
280     x = *q;
281     goto loop;
282   }
283 }
284 
sexp_mark_one_start(sexp ctx,sexp * types,sexp x)285 static void sexp_mark_one_start (sexp ctx, sexp* types, sexp x) {
286   struct sexp_mark_stack_ptr_t **ptr = &sexp_context_mark_stack_ptr(ctx);
287   sexp *p, *q;
288   sexp_mark_one(ctx, types, x);
289 
290   while (*ptr) {
291     p = (*ptr)->start;
292     q = (*ptr)->end;
293     sexp_mark_stack_pop(ctx);
294     while (p < q) {
295       sexp_mark_one(ctx, types, *p++);
296     }
297   }
298 }
299 
sexp_mark(sexp ctx,sexp x)300 void sexp_mark (sexp ctx, sexp x) {
301   sexp_mark_one_start(ctx, sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)), x);
302 }
303 
304 #if SEXP_USE_CONSERVATIVE_GC
305 
stack_references_pointer_p(sexp ctx,sexp x)306 int stack_references_pointer_p (sexp ctx, sexp x) {
307   sexp *p;
308   for (p=(&x)+1; p<stack_base; p++)
309     if (*p == x)
310       return 1;
311   return 0;
312 }
313 
314 #if SEXP_USE_TRACK_ALLOC_BACKTRACE
sexp_print_gc_trace(sexp ctx,sexp p)315 void sexp_print_gc_trace(sexp ctx, sexp p) {
316   int i;
317   char **debug_text = backtrace_symbols(p->backtrace, SEXP_BACKTRACE_SIZE);
318   for (i=0; i < SEXP_BACKTRACE_SIZE; i++)
319     fprintf(stderr, SEXP_BANNER("    : %s"), debug_text[i]);
320   free(debug_text);
321 }
322 #else
323 #define sexp_print_gc_trace(ctx, p)
324 #endif
325 
sexp_conservative_mark(sexp ctx)326 void sexp_conservative_mark (sexp ctx) {
327   sexp_heap h = sexp_context_heap(ctx);
328   sexp p, end;
329   sexp_free_list q, r;
330   for ( ; h; h=h->next) {   /* just scan the whole heap */
331     p = sexp_heap_first_block(h);
332     q = h->free_list;
333     end = sexp_heap_end(h);
334     while (p < end) {
335       for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
336         ;
337       if ((char*)r == (char*)p) {
338         p = (sexp) (((char*)p) + r->size);
339         continue;
340       }
341       if (!sexp_markedp(p) && stack_references_pointer_p(ctx, p)) {
342 #ifdef SEXP_USE_CONSERVATIVE_GC_PRESERVE_TAG
343         if (sexp_pointer_tag(p) == SEXP_USE_CONSERVATIVE_GC_PRESERVE_TAG)
344 #endif
345         if (1) {
346 #if SEXP_USE_DEBUG_GC > 3
347           if (p && sexp_pointerp(p)) {
348             fprintf(stderr, SEXP_BANNER("MISS: %p [%d]: %s"), p,
349                     sexp_pointer_tag(p), sexp_pointer_source(p));
350             sexp_print_gc_trace(ctx, p);
351             fflush(stderr);
352           }
353 #endif
354           sexp_mark(ctx, p);
355         }
356       }
357       p = (sexp) (((char*)p)+sexp_heap_align(sexp_allocated_bytes(ctx, p)));
358     }
359   }
360 }
361 
362 #else
363 #define sexp_conservative_mark(ctx)
364 #endif
365 
366 #if SEXP_USE_WEAK_REFERENCES
sexp_reset_weak_references(sexp ctx)367 int sexp_reset_weak_references(sexp ctx) {
368   int i, len, broke, all_reset_p;
369   sexp_heap h;
370   sexp p, t, end, *v;
371   sexp_free_list q, r;
372   if (sexp_not(sexp_global(ctx, SEXP_G_WEAK_OBJECTS_PRESENT)))
373     return 0;
374   broke = 0;
375   /* just scan the whole heap */
376   for (h = sexp_context_heap(ctx) ; h; h=h->next) {
377     p = sexp_heap_first_block(h);
378     q = h->free_list;
379     end = sexp_heap_end(h);
380     while (p < end) {
381       /* find the preceding and succeeding free list pointers */
382       for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
383         ;
384       if ((char*)r == (char*)p) { /* this is a free block, skip it */
385         p = (sexp) (((char*)p) + r->size);
386         continue;
387       }
388       if (sexp_valid_object_p(ctx, p) && sexp_markedp(p)) {
389         t = sexp_object_type(ctx, p);
390         if (sexp_type_weak_base(t) > 0) {
391           all_reset_p = 1;
392           v = (sexp*) ((char*)p + sexp_type_weak_base(t));
393           len = sexp_type_num_weak_slots_of_object(t, p);
394           for (i=0; i<len; i++) {
395             if (v[i] && sexp_pointerp(v[i]) && ! sexp_markedp(v[i])) {
396               v[i] = SEXP_FALSE;
397               sexp_brokenp(p) = 1;
398             } else {
399               all_reset_p = 0;
400             }
401           }
402           if (all_reset_p) {      /* ephemerons */
403             broke++;
404             len += sexp_type_weak_len_extra(t);
405             for ( ; i<len; i++) v[i] = SEXP_FALSE;
406           }
407         }
408       }
409       p = (sexp) (((char*)p)+sexp_heap_align(sexp_allocated_bytes(ctx, p)));
410     }
411   }
412   sexp_debug_printf("%p (broke %d weak references)", ctx, broke);
413   return broke;
414 }
415 #else
416 #define sexp_reset_weak_references(ctx) 0
417 #endif
418 
419 #if SEXP_USE_FINALIZERS
sexp_finalize(sexp ctx)420 sexp sexp_finalize (sexp ctx) {
421   size_t size;
422   sexp p, t, end;
423   sexp_free_list q, r;
424   sexp_proc2 finalizer;
425   sexp_sint_t finalize_count = 0;
426   sexp_heap h = sexp_context_heap(ctx);
427 #if SEXP_USE_DL
428   sexp_sint_t free_dls = 0, pass = 0;
429  loop:
430 #endif
431   /* scan over the whole heap */
432   for ( ; h; h=h->next) {
433     p = sexp_heap_first_block(h);
434     q = h->free_list;
435     end = sexp_heap_end(h);
436     while (p < end) {
437       /* find the preceding and succeeding free list pointers */
438       for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
439         ;
440       if ((char*)r == (char*)p) { /* this is a free block, skip it */
441         p = (sexp) (((char*)p) + r->size);
442         continue;
443       }
444       size = sexp_heap_align(sexp_allocated_bytes(ctx, p));
445       if (size == 0) {
446         return SEXP_FALSE;
447       }
448       if (!sexp_markedp(p)) {
449         t = sexp_object_type(ctx, p);
450         finalizer = sexp_type_finalize(t);
451         if (finalizer) {
452           finalize_count++;
453 #if SEXP_USE_DL
454           if (sexp_type_tag(t) == SEXP_DL && pass <= 0)
455             free_dls = 1;
456           else
457 #endif
458             finalizer(ctx, NULL, 1, p);
459         }
460       }
461       p = (sexp) (((char*)p)+size);
462     }
463   }
464 #if SEXP_USE_DL
465   if (free_dls && pass++ <= 0) goto loop;
466 #endif
467   return sexp_make_fixnum(finalize_count);
468 }
469 #endif
470 
sexp_sweep(sexp ctx,size_t * sum_freed_ptr)471 sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) {
472   size_t freed, max_freed=0, sum_freed=0, size;
473   sexp_heap h = sexp_context_heap(ctx);
474   sexp p, end;
475   sexp_free_list q, r, s;
476   /* scan over the whole heap */
477   for ( ; h; h=h->next) {
478     p = sexp_heap_first_block(h);
479     q = h->free_list;
480     end = sexp_heap_end(h);
481     while (p < end) {
482       /* find the preceding and succeeding free list pointers */
483       for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
484         ;
485       if ((char*)r == (char*)p) { /* this is a free block, skip it */
486         p = (sexp) (((char*)p) + r->size);
487         continue;
488       }
489       size = sexp_heap_align(sexp_allocated_bytes(ctx, p));
490 #if SEXP_USE_DEBUG_GC > 1
491       if (!sexp_valid_object_p(ctx, p))
492         fprintf(stderr, SEXP_BANNER("%p sweep: invalid object at %p"), ctx, p);
493       if ((char*)q + q->size > (char*)p)
494         fprintf(stderr, SEXP_BANNER("%p sweep: bad size at %p < %p + %lu"),
495                 ctx, p, q, q->size);
496       if (r && ((char*)p)+size > (char*)r)
497         fprintf(stderr, SEXP_BANNER("%p sweep: bad size at %p + %lu > %p"),
498                 ctx, p, size, r);
499 #endif
500       if (!sexp_markedp(p)) {
501         /* free p */
502         sum_freed += size;
503         if (((((char*)q) + q->size) == (char*)p) && (q != h->free_list)) {
504           /* merge q with p */
505           if (r && r->size && ((((char*)p)+size) == (char*)r)) {
506             /* ... and with r */
507             q->next = r->next;
508             freed = q->size + size + r->size;
509             p = (sexp) (((char*)p) + size + r->size);
510           } else {
511             freed = q->size + size;
512             p = (sexp) (((char*)p)+size);
513           }
514           q->size = freed;
515         } else {
516           s = (sexp_free_list)p;
517           if (r && r->size && ((((char*)p)+size) == (char*)r)) {
518             /* merge p with r */
519             s->size = size + r->size;
520             s->next = r->next;
521             q->next = s;
522             freed = size + r->size;
523           } else {
524             s->size = size;
525             s->next = r;
526             q->next = s;
527             freed = size;
528           }
529           p = (sexp) (((char*)p)+freed);
530         }
531         if (freed > max_freed)
532           max_freed = freed;
533       } else {
534         sexp_markedp(p) = 0;
535         p = (sexp) (((char*)p)+size);
536       }
537     }
538   }
539   if (sum_freed_ptr) *sum_freed_ptr = sum_freed;
540   return sexp_make_fixnum(max_freed);
541 }
542 
543 #if SEXP_USE_GLOBAL_SYMBOLS
sexp_mark_global_symbols(sexp ctx)544 void sexp_mark_global_symbols(sexp ctx) {
545   int i;
546   for (i=0; i<SEXP_SYMBOL_TABLE_SIZE; i++)
547     sexp_mark(ctx, sexp_symbol_table[i]);
548 }
549 #else
550 #define sexp_mark_global_symbols(ctx)
551 #endif
552 
sexp_gc(sexp ctx,size_t * sum_freed)553 sexp sexp_gc (sexp ctx, size_t *sum_freed) {
554   sexp res, finalized SEXP_NO_WARN_UNUSED;
555 #if SEXP_USE_TIME_GC
556   sexp_uint_t gc_usecs;
557   struct rusage start, end;
558   getrusage(RUSAGE_SELF, &start);
559   sexp_debug_printf("%p (heap: %p size: %lu)", ctx, sexp_context_heap(ctx),
560                     sexp_heap_total_size(sexp_context_heap(ctx)));
561 #endif
562   sexp_mark_global_symbols(ctx);
563   sexp_mark(ctx, ctx);
564   sexp_conservative_mark(ctx);
565   sexp_reset_weak_references(ctx);
566   finalized = sexp_finalize(ctx);
567   res = sexp_sweep(ctx, sum_freed);
568   ++sexp_context_gc_count(ctx);
569 #if SEXP_USE_TIME_GC
570   getrusage(RUSAGE_SELF, &end);
571   gc_usecs = (end.ru_utime.tv_sec - start.ru_utime.tv_sec) * 1000000 +
572     end.ru_utime.tv_usec - start.ru_utime.tv_usec;
573   sexp_context_gc_usecs(ctx) += gc_usecs;
574   sexp_debug_printf("%p (freed: %lu max_freed: %lu finalized: %lu time: %luus)",
575                     ctx, (sum_freed ? *sum_freed : 0), sexp_unbox_fixnum(res),
576                     sexp_unbox_fixnum(finalized), gc_usecs);
577 #endif
578   return res;
579 }
580 
sexp_make_heap(size_t size,size_t max_size,size_t chunk_size)581 sexp_heap sexp_make_heap (size_t size, size_t max_size, size_t chunk_size) {
582   sexp_free_list free, next;
583   sexp_heap h;
584 #if SEXP_USE_MMAP_GC
585   h =  mmap(NULL, sexp_heap_pad_size(size), PROT_READ|PROT_WRITE,
586             MAP_ANON|MAP_PRIVATE, -1, 0);
587   if (h == MAP_FAILED) return NULL;
588 #else
589   h =  sexp_malloc(sexp_heap_pad_size(size));
590   if (! h) return NULL;
591 #endif
592   h->size = size;
593   h->max_size = max_size;
594   h->chunk_size = chunk_size;
595   h->data = (char*) sexp_heap_align(sizeof(h->data)+(sexp_uint_t)&(h->data));
596   free = h->free_list = (sexp_free_list) h->data;
597   h->next = NULL;
598   next = (sexp_free_list) (((char*)free)+sexp_heap_align(sexp_free_chunk_size));
599   free->size = 0; /* actually sexp_heap_align(sexp_free_chunk_size) */
600   free->next = next;
601   next->size = size - sexp_heap_align(sexp_free_chunk_size);
602   next->next = NULL;
603 #if SEXP_USE_DEBUG_GC
604   fprintf(stderr, SEXP_BANNER("heap: %p-%p data: %p-%p"),
605           h, ((char*)h)+sexp_heap_pad_size(size), h->data, h->data + size);
606   fprintf(stderr, SEXP_BANNER("first: %p end: %p"),
607           sexp_heap_first_block(h), sexp_heap_end(h));
608   fprintf(stderr, SEXP_BANNER("free1: %p-%p free2: %p-%p"),
609           free, ((char*)free)+free->size, next, ((char*)next)+next->size);
610 #endif
611   return h;
612 }
613 
sexp_grow_heap(sexp ctx,size_t size,size_t chunk_size)614 int sexp_grow_heap (sexp ctx, size_t size, size_t chunk_size) {
615   size_t cur_size, new_size;
616   sexp_heap tmp, h = sexp_heap_last(sexp_context_heap(ctx));
617 #if SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
618   for (tmp=sexp_context_heap(ctx); tmp; tmp=tmp->next)
619     if (tmp->chunk_size == size) {
620       while (tmp->next && tmp->next->chunk_size == size)
621         tmp = tmp->next;
622       h = tmp;
623       chunk_size = size;
624       break;
625     }
626 #endif
627   cur_size = h->size;
628   new_size = (size_t) ceil(SEXP_GROW_HEAP_FACTOR * (double) (sexp_heap_align(((cur_size > size) ? cur_size : size))));
629   tmp = sexp_make_heap(new_size, h->max_size, chunk_size);
630   if (tmp) {
631     tmp->next = h->next;
632     h->next = tmp;
633   }
634   return (h->next != NULL);
635 }
636 
sexp_try_alloc(sexp ctx,size_t size)637 void* sexp_try_alloc (sexp ctx, size_t size) {
638   sexp_free_list ls1, ls2, ls3;
639   sexp_heap h;
640 #if SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
641   int found_fixed = 0;
642 #endif
643   for (h=sexp_context_heap(ctx); h; h=h->next) {
644 #if SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
645     if (h->chunk_size) {
646       if (h->chunk_size != size)
647         continue;
648       found_fixed = 1;
649     } else if (found_fixed) {   /* don't use a non-fixed heap */
650       return NULL;
651     }
652 #endif
653     for (ls1=h->free_list, ls2=ls1->next; ls2; ls1=ls2, ls2=ls2->next) {
654       if (ls2->size >= size) {
655 #if SEXP_USE_DEBUG_GC > 1
656         ls3 = (sexp_free_list) sexp_heap_end(h);
657         if (ls2 >= ls3)
658           fprintf(stderr, "alloced %lu bytes past end of heap: %p (%lu) >= %p"
659                   " next: %p (%lu)\n", size, ls2, ls2->size, ls3, ls2->next,
660                   (ls2->next ? ls2->next->size : 0));
661 #endif
662         if (ls2->size >= (size + SEXP_MINIMUM_OBJECT_SIZE)) {
663           ls3 = (sexp_free_list) (((char*)ls2)+size); /* the tail after ls2 */
664           ls3->size = ls2->size - size;
665           ls3->next = ls2->next;
666           ls1->next = ls3;
667         } else {                  /* take the whole chunk */
668           ls1->next = ls2->next;
669         }
670         memset((void*)ls2, 0, size);
671         return ls2;
672       }
673     }
674   }
675   return NULL;
676 }
677 
678 #if SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
sexp_find_fixed_chunk_heap_usage(sexp ctx,size_t size,size_t * sum_freed,size_t * total_size)679 int sexp_find_fixed_chunk_heap_usage(sexp ctx, size_t size, size_t* sum_freed, size_t* total_size) {
680   sexp_heap h;
681   sexp_free_list ls;
682   size_t avail=0, total=0;
683   for (h=sexp_context_heap(ctx); h; h=h->next) {
684     if (h->chunk_size == size || !h->chunk_size) {
685       for (; h && (h->chunk_size == size || !h->chunk_size); h=h->next) {
686         total += h->size;
687         for (ls=h->free_list; ls; ls=ls->next)
688           avail += ls->size;
689       }
690       *sum_freed = avail;
691       *total_size = total;
692       return h && h->chunk_size > 0;
693     }
694   }
695   return 0;
696 }
697 #endif
698 
sexp_alloc(sexp ctx,size_t size)699 void* sexp_alloc (sexp ctx, size_t size) {
700   void *res;
701   size_t max_freed, sum_freed, total_size=0;
702   sexp_heap h = sexp_context_heap(ctx);
703 #if SEXP_USE_TRACK_ALLOC_SIZES
704   size_t size_bucket;
705 #endif
706 #if SEXP_USE_TRACK_ALLOC_TIMES
707   sexp_uint_t alloc_time;
708   struct timeval start, end;
709   gettimeofday(&start, NULL);
710 #endif
711   size = sexp_heap_align(size) + SEXP_GC_PAD;
712 #if SEXP_USE_TRACK_ALLOC_SIZES
713   size_bucket = (size - SEXP_GC_PAD) / sexp_heap_align(1) - 1;
714   ++sexp_context_alloc_histogram(ctx)[size_bucket >= SEXP_ALLOC_HISTOGRAM_BUCKETS ? SEXP_ALLOC_HISTOGRAM_BUCKETS-1 : size_bucket];
715 #endif
716   res = sexp_try_alloc(ctx, size);
717   if (! res) {
718     max_freed = sexp_unbox_fixnum(sexp_gc(ctx, &sum_freed));
719 #if SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
720     sexp_find_fixed_chunk_heap_usage(ctx, size, &sum_freed, &total_size);
721 #else
722     total_size = sexp_heap_total_size(sexp_context_heap(ctx));
723 #endif
724     if (((max_freed < size)
725          || ((total_size > sum_freed)
726              && (total_size - sum_freed) > (total_size*SEXP_GROW_HEAP_RATIO)))
727         && ((!h->max_size) || (total_size < h->max_size)))
728       sexp_grow_heap(ctx, size, 0);
729     res = sexp_try_alloc(ctx, size);
730     if (! res) {
731       res = sexp_global(ctx, SEXP_G_OOM_ERROR);
732       sexp_debug_printf("ran out of memory allocating %lu bytes => %p", size, res);
733     }
734   }
735 #if SEXP_USE_TRACK_ALLOC_TIMES
736   gettimeofday(&end, NULL);
737   alloc_time = 1000000*(end.tv_sec - start.tv_sec) + (end.tv_usec - start.tv_usec);
738   sexp_context_alloc_count(ctx) += 1;
739   sexp_context_alloc_usecs(ctx) += alloc_time;
740   sexp_context_alloc_usecs_sq(ctx) += alloc_time*alloc_time;
741 #endif
742   return res;
743 }
744 
745 
sexp_gc_init(void)746 void sexp_gc_init (void) {
747 #if SEXP_USE_GLOBAL_HEAP || SEXP_USE_CONSERVATIVE_GC
748   sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE);
749 #endif
750 #if SEXP_USE_GLOBAL_HEAP
751   sexp_global_heap = sexp_make_heap(size, SEXP_MAXIMUM_HEAP_SIZE, 0);
752 #endif
753 #if SEXP_USE_CONSERVATIVE_GC
754   /* the +32 is a hack, but this is just for debugging anyway */
755   stack_base = ((sexp*)&size) + 32;
756 #endif
757 }
758 
759 #endif  /* ! SEXP_USE_BOEHM && ! SEXP_USE_MALLOC */
760