static sexp sexp_free_sizes (sexp ctx, sexp self, sexp_sint_t n) {
size_t freed;
sexp_uint_t sizes[512];
sexp_sint_t i;
sexp_heap h = sexp_context_heap(ctx);
sexp_free_list q;
sexp_gc_var2(res, tmp);
/* run gc once to remove unused variables */
sexp_gc(ctx, &freed);
/* initialize stats */
for (i=0; i<512; i++)
sizes[i]=0;
/* loop over each free block */
for ( ; h; h=h->next)
for (q=h->free_list; q; q=q->next)
sizes[sexp_heap_chunks(q->size) > 511 ? 511 : sexp_heap_chunks(q->size)]++;
/* build and return results */
sexp_gc_preserve2(ctx, res, tmp);
res = SEXP_NULL;
for (i=511; i>=0; i--)
if (sizes[i]) {
tmp = sexp_cons(ctx, sexp_make_fixnum(i), sexp_make_fixnum(sizes[i]));
res = sexp_cons(ctx, tmp, res);
}
sexp_gc_release2(ctx);
return res;
}
static int sexp_save_image (sexp ctx, const char* path) {
sexp_heap heap;
FILE* file;
struct sexp_image_header_t header;
heap = sexp_context_heap(ctx);
if (heap->next) {
fprintf(stderr, "can't save image for a chunked heap, try a larger initial heap with -h\n");
return 0;
}
file = fopen(path, "w");
if (!file) {
fprintf(stderr, "couldn't open image file for writing: %s\n", path);
return 0;
}
memcpy(&header.magic, SEXP_IMAGE_MAGIC, sizeof(header.magic));
memcpy(&header.abi, SEXP_ABI_IDENTIFIER, sizeof(header.abi));
header.major = SEXP_IMAGE_MAJOR_VERSION;
header.minor = SEXP_IMAGE_MINOR_VERSION;
header.size = heap->size;
header.base = heap;
header.context = ctx;
sexp_gc(ctx, NULL);
if (! (fwrite(&header, sizeof(header), 1, file) == 1
&& fwrite(heap, heap->size, 1, file) == 1)) {
fprintf(stderr, "error writing image file\n");
return 0;
}
fclose(file);
return 1;
}
static sexp sexp_heap_walk (sexp ctx, int depth, int printp) {
size_t freed;
sexp_uint_t stats[256], hi_type=0, i;
sexp_heap h = sexp_context_heap(ctx);
sexp p, out=SEXP_FALSE;
sexp_free_list q, r;
char *end;
sexp_gc_var3(res, tmp, name);
if (printp)
out = sexp_parameter_ref(ctx,
sexp_env_ref(ctx,
sexp_context_env(ctx),
sexp_global(ctx,SEXP_G_CUR_OUT_SYMBOL),
SEXP_FALSE));
/* run gc once to remove unused variables */
sexp_gc(ctx, &freed);
/* initialize stats */
for (i=0; i<256; i++) stats[i]=0;
/* loop over each heap chunk */
for ( ; h; h=h->next) {
p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair)));
q = h->free_list;
end = (char*)h->data + h->size;
while (((char*)p) < end) {
/* find the preceding and succeeding free list pointers */
for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
;
if ((char*)r == (char*)p) { /* this is a free block, skip */
p = (sexp) (((char*)p) + r->size);
continue;
}
/* otherwise maybe print, then increment the stat and continue */
if (sexp_oportp(out)) {
sexp_print_simple(ctx, p, out, depth);
sexp_write_char(ctx, '\n', out);
}
stats[sexp_pointer_tag(p)]++;
if (sexp_pointer_tag(p) > hi_type)
hi_type = sexp_pointer_tag(p);
p = (sexp) (((char*)p) + sexp_heap_align(sexp_allocated_bytes(ctx, p)));
}
}
/* build and return results */
sexp_gc_preserve3(ctx, res, tmp, name);
res = SEXP_NULL;
for (i=hi_type; i>0; i--)
if (stats[i]) {
name = sexp_string_to_symbol(ctx, sexp_type_name_by_index(ctx, i));
tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i]));
res = sexp_cons(ctx, tmp, res);
}
sexp_gc_release3(ctx);
return res;
}
static sexp sexp_last_context (sexp ctx, sexp *cstack) {
sexp res=SEXP_FALSE;
#if ! SEXP_USE_BOEHM
sexp p;
sexp_sint_t i;
sexp_heap h = sexp_context_heap(ctx);
for (i=0; i<SEXP_LAST_CONTEXT_CHECK_LIMIT; i++) {
p = cstack[i];
if (p && (p != ctx) && sexp_pointerp(p) && in_heap_p(h, p)
&& (sexp_pointer_tag(p) == SEXP_CONTEXT)
&& (sexp_context_heap(p) == h)) {
res = p;
break;
}
}
#endif
return res;
}