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