1442 lines
36 KiB
C
1442 lines
36 KiB
C
#define _POSIX_C_SOURCE 199309L
|
|
|
|
#include <assert.h>
|
|
#include <ctype.h>
|
|
#include <inttypes.h>
|
|
#include <setjmp.h>
|
|
#include <stdbool.h>
|
|
#include <stdio.h>
|
|
#include <stdlib.h>
|
|
#include <string.h>
|
|
#include <time.h>
|
|
|
|
#include "gc.h"
|
|
|
|
#if _CLOCK_MONOTONIC
|
|
# define TIMING_CLOCK CLOCK_MONOTONIC
|
|
#else
|
|
# define TIMING_CLOCK CLOCK_REALTIME
|
|
#endif
|
|
|
|
gc_stats_t gc_stats;
|
|
|
|
/* Helper macros to reduce duplication */
|
|
#define VECTOR_BYTES(nelem) (sizeof(vector_t) + (sizeof(value_t) * (nelem)))
|
|
#define BYTESTR_BYTES(size) (sizeof(byte_string_t) + (size))
|
|
#define STRUCT_BYTES(nslots) (sizeof(struct_t) + (sizeof(value_t) * (nslots)))
|
|
|
|
/* Alignment must ensure each object has enough room to hold a forwarding object */
|
|
#define GC_ALIGNMENT ((size_t)(sizeof(object_t)))
|
|
|
|
/* Smaller block sizes allow for more precise GC, but require more memory for the bitmap. */
|
|
/* The block bitmap will be allocated at startup assuming a max. heap size of 2GB. */
|
|
/* The default of 128 KB/block should require a 2 KB bitmap. */
|
|
#define GC_DIRTY_BLOCK_SIZE (128UL << 10)
|
|
|
|
/****************************************************************************/
|
|
|
|
static value_t gc_weak_box_list;
|
|
static value_t gc_will_list;
|
|
static value_t gc_will_active_list;
|
|
|
|
static gc_root_t gc_root_list = {
|
|
.value = UNDEFINED,
|
|
.prev = &gc_root_list,
|
|
.next = &gc_root_list
|
|
};
|
|
|
|
void register_gc_root(gc_root_t *root, value_t v)
|
|
{
|
|
root->value = v;
|
|
root->next = &gc_root_list;
|
|
gc_root_list.prev->next = root;
|
|
root->prev = gc_root_list.prev;
|
|
gc_root_list.prev = root;
|
|
}
|
|
|
|
void unregister_gc_root(gc_root_t *root)
|
|
{
|
|
assert(root && root->prev && root->next); /* Uninitialized */
|
|
assert((root->prev != root) && (root->next != root)); /* Already removed */
|
|
|
|
/* Cut the given root out of the list */
|
|
root->prev->next = root->next;
|
|
root->next->prev = root->prev;
|
|
|
|
/* Remove dead references to root list; protects against double-removal */
|
|
root->prev = root->next = root;
|
|
}
|
|
|
|
/****************************************************************************/
|
|
|
|
bool get_boolean(value_t v)
|
|
{
|
|
release_assert(is_boolean(v));
|
|
return (v != FALSE_VALUE);
|
|
}
|
|
|
|
fixnum_t get_fixnum(value_t v)
|
|
{
|
|
release_assert(is_fixnum(v));
|
|
return _get_fixnum(v);
|
|
}
|
|
|
|
object_t *get_object(value_t v)
|
|
{
|
|
release_assert(is_object(v));
|
|
return _get_object(v);
|
|
}
|
|
|
|
/* No one outside this module should care... */
|
|
static inline bool is_broken_heart(value_t v)
|
|
{
|
|
return is_object(v) && (_get_object(v)->tag == BROKEN_HEART);
|
|
}
|
|
|
|
value_t cons(value_t car, value_t cdr)
|
|
{
|
|
gc_root_t car_root, cdr_root;
|
|
pair_t *p;
|
|
|
|
register_gc_root(&car_root, car);
|
|
register_gc_root(&cdr_root, cdr);
|
|
|
|
p = (pair_t*)gc_alloc(sizeof(pair_t));
|
|
p->car = car_root.value;
|
|
p->cdr = cdr_root.value;
|
|
|
|
unregister_gc_root(&car_root);
|
|
unregister_gc_root(&cdr_root);
|
|
|
|
return pair_value(p);
|
|
}
|
|
|
|
pair_t *get_pair(value_t v)
|
|
{
|
|
release_assert(is_pair(v));
|
|
return _get_pair(v);
|
|
}
|
|
|
|
value_t make_box(value_t initial_value)
|
|
{
|
|
gc_root_t iv_root;
|
|
box_t *box;
|
|
|
|
register_gc_root(&iv_root, initial_value);
|
|
|
|
box = (box_t*)gc_alloc(sizeof(box_t));
|
|
box->tag = TYPE_TAG_BOX;
|
|
box->value = iv_root.value;
|
|
|
|
unregister_gc_root(&iv_root);
|
|
|
|
return object_value(box);
|
|
}
|
|
|
|
box_t *get_box(value_t v)
|
|
{
|
|
release_assert(is_box(v));
|
|
return _get_box(v);
|
|
}
|
|
|
|
value_t make_vector(size_t nelem, value_t initial_value)
|
|
{
|
|
gc_root_t iv_root;
|
|
vector_t *vec;
|
|
|
|
register_gc_root(&iv_root, initial_value);
|
|
|
|
vec = (vector_t*)gc_alloc(VECTOR_BYTES(nelem));
|
|
vec->tag = TYPE_TAG_VECTOR;
|
|
vec->size = nelem;
|
|
|
|
for (int i = 0; i < nelem; ++i)
|
|
vec->elements[i] = iv_root.value;
|
|
|
|
unregister_gc_root(&iv_root);
|
|
|
|
return object_value(vec);
|
|
}
|
|
|
|
vector_t *get_vector(value_t v)
|
|
{
|
|
release_assert(is_vector(v));
|
|
return _get_vector(v);
|
|
}
|
|
|
|
value_t make_byte_string(size_t size, int default_value)
|
|
{
|
|
const size_t nbytes = BYTESTR_BYTES(size);
|
|
byte_string_t *str;
|
|
|
|
str = (byte_string_t*)gc_alloc(nbytes);
|
|
str->tag = TYPE_TAG_BYTESTR;
|
|
str->size = size;
|
|
|
|
memset(str->bytes, default_value, size);
|
|
|
|
return object_value(str);
|
|
}
|
|
|
|
byte_string_t *get_byte_string(value_t v)
|
|
{
|
|
release_assert(is_byte_string(v));
|
|
return _get_byte_string(v);
|
|
}
|
|
|
|
value_t string_to_value(const char *s)
|
|
{
|
|
size_t len = strlen(s);
|
|
value_t v = make_byte_string(len, '\0');
|
|
memcpy(_get_byte_string(v)->bytes, s, len);
|
|
return v;
|
|
}
|
|
|
|
char *value_to_string(value_t v)
|
|
{
|
|
byte_string_t *str = get_byte_string(v);
|
|
char *s = (char*)malloc(str->size + 1);
|
|
|
|
memcpy(s, str->bytes, str->size);
|
|
s[str->size] = '\0';
|
|
|
|
return s;
|
|
}
|
|
|
|
int byte_strcmp(value_t s1, value_t s2)
|
|
{
|
|
byte_string_t *str1 = get_byte_string(s1);
|
|
byte_string_t *str2 = get_byte_string(s2);
|
|
|
|
if (str1->size < str2->size)
|
|
return -1;
|
|
else if (str1->size > str2->size)
|
|
return 1;
|
|
else
|
|
return memcmp(str1->bytes, str2->bytes, str1->size);
|
|
}
|
|
|
|
value_t make_struct(value_t type, size_t nslots)
|
|
{
|
|
gc_root_t type_root;
|
|
struct_t *s;
|
|
|
|
register_gc_root(&type_root, type);
|
|
|
|
s = (struct_t*)gc_alloc(STRUCT_BYTES(nslots));
|
|
s->tag = TYPE_TAG_STRUCT;
|
|
s->type = type_root.value;
|
|
s->nslots = nslots;
|
|
|
|
for (int i = 0; i < nslots; ++i)
|
|
s->slots[i] = UNDEFINED;
|
|
|
|
unregister_gc_root(&type_root);
|
|
|
|
return object_value(s);
|
|
}
|
|
|
|
struct_t *get_struct(value_t v)
|
|
{
|
|
release_assert(is_struct(v));
|
|
return _get_struct(v);
|
|
}
|
|
|
|
value_t make_weak_box(value_t initial_value)
|
|
{
|
|
gc_root_t iv_root;
|
|
weak_box_t *box;
|
|
|
|
register_gc_root(&iv_root, initial_value);
|
|
|
|
box = (weak_box_t*)gc_alloc(sizeof(weak_box_t));
|
|
box->tag = TYPE_TAG_WEAK_BOX;
|
|
box->value = iv_root.value;
|
|
box->next = gc_weak_box_list;
|
|
gc_weak_box_list = object_value(box);
|
|
|
|
unregister_gc_root(&iv_root);
|
|
|
|
return object_value(box);
|
|
}
|
|
|
|
weak_box_t *get_weak_box(value_t v)
|
|
{
|
|
release_assert(is_weak_box(v));
|
|
return _get_weak_box(v);
|
|
}
|
|
|
|
void register_finalizer(value_t value, value_t finalizer)
|
|
{
|
|
/* Non-objects are never GC'd, so their finalizers will never be invoked. */
|
|
if (is_object(value))
|
|
{
|
|
gc_root_t value_root, finalizer_root;
|
|
will_t *w;
|
|
|
|
register_gc_root(&value_root, value);
|
|
register_gc_root(&finalizer_root, finalizer);
|
|
|
|
w = (will_t*)gc_alloc(sizeof(will_t));
|
|
w->tag = TYPE_TAG_WILL;
|
|
w->value = value_root.value;
|
|
w->finalizer = finalizer_root.value;
|
|
w->next = gc_will_list;
|
|
|
|
gc_will_list = object_value(w);
|
|
|
|
unregister_gc_root(&value_root);
|
|
unregister_gc_root(&finalizer_root);
|
|
}
|
|
}
|
|
|
|
/* The 'will' accessors are private to the GC, unlike other similar routines. */
|
|
static inline will_t *_get_will(value_t v)
|
|
{
|
|
return (will_t*)_get_object(v);
|
|
}
|
|
|
|
static will_t *get_will(value_t v)
|
|
{
|
|
release_assert(is_will(v));
|
|
return _get_will(v);
|
|
}
|
|
|
|
value_t make_float(native_float_t value)
|
|
{
|
|
float_object_t *obj;
|
|
|
|
obj = (float_object_t*)gc_alloc(sizeof(float_object_t));
|
|
obj->tag = TYPE_TAG_FLOAT;
|
|
obj->value = value;
|
|
|
|
return object_value(obj);
|
|
}
|
|
|
|
native_float_t get_float(value_t v)
|
|
{
|
|
release_assert(is_float(v));
|
|
return _get_float(v);
|
|
}
|
|
|
|
value_t make_builtin_fn(builtin_fn_t *fn)
|
|
{
|
|
builtin_fn_object_t *obj;
|
|
|
|
obj = (builtin_fn_object_t*)gc_alloc(sizeof(builtin_fn_object_t));
|
|
obj->tag = TYPE_TAG_BUILTIN;
|
|
obj->fn = fn;
|
|
|
|
return object_value(obj);
|
|
}
|
|
|
|
builtin_fn_t *get_builtin_fn(value_t v)
|
|
{
|
|
release_assert(is_builtin_fn(v));
|
|
return _get_builtin_fn(v);
|
|
}
|
|
|
|
/*************************** Common Collector Code **************************/
|
|
|
|
static bool gc_enabled;
|
|
static bool gc_in_gen0_collection;
|
|
static bool gc_in_gen1_collection;
|
|
|
|
/* Also used from Gen-0 code to track new Gen-1 objects */
|
|
static char *gc_gen1_ranges[2];
|
|
static size_t gc_gen1_min_size;
|
|
static size_t gc_gen1_max_size;
|
|
static size_t gc_gen1_soft_limit;
|
|
|
|
static int gc_gen1_current_range;
|
|
static char *gc_gen1_free_ptr;
|
|
static char *gc_gen1_range_end;
|
|
|
|
static size_t gc_gen1_max_blocks;
|
|
static uint32_t *gc_gen1_dirty_bits;
|
|
static char **gc_gen1_block_starts;
|
|
|
|
/* A convenient shorthand */
|
|
#define gc_gen1_other_range() (1-gc_gen1_current_range)
|
|
|
|
static inline size_t gc_align(size_t nbytes) __attribute__ ((const));
|
|
static void transfer_roots(void);
|
|
static size_t transfer_children(object_t *obj);
|
|
static void process_weak_boxes(void);
|
|
static void process_wills(void);
|
|
static void update_weak_box_list(void);
|
|
|
|
static void gc_gen0_init(size_t gen0_size);
|
|
static void gc_gen1_init(size_t min_size, size_t max_size);
|
|
|
|
static int gc_gen1_range_of(void *object) __attribute__ ((const));
|
|
static size_t gc_gen1_block_of(void *obj) __attribute__ ((const));
|
|
static inline size_t gc_gen1_free_space(void);
|
|
|
|
static void *gc_alloc_gen1(size_t nbytes);
|
|
static void collect_gen1_garbage(size_t min_free);
|
|
static void gc_gen1_clear_dirty_bits(void);
|
|
|
|
static inline size_t gc_gen1_free_space(void)
|
|
{
|
|
return gc_gen1_range_end - gc_gen1_free_ptr;
|
|
}
|
|
|
|
static inline size_t gc_align(size_t nbytes)
|
|
{
|
|
return ((nbytes + GC_ALIGNMENT - 1) & ~(GC_ALIGNMENT - 1));
|
|
}
|
|
|
|
void gc_init(size_t min_size, size_t max_size)
|
|
{
|
|
gc_gen0_init(min_size);
|
|
gc_gen1_init(min_size, max_size);
|
|
|
|
gc_weak_box_list = NIL;
|
|
gc_will_list = NIL;
|
|
gc_will_active_list = NIL;
|
|
|
|
clear_gc_stats();
|
|
|
|
gc_enabled = true;
|
|
}
|
|
|
|
void clear_gc_stats(void)
|
|
{
|
|
gc_stats.gen0_passes = 0;
|
|
gc_stats.gen1_passes = 0;
|
|
gc_stats.total_ns = 0;
|
|
gc_stats.total_freed = 0;
|
|
gc_stats.high_water = 0;
|
|
gc_stats.max_ns = 0;
|
|
}
|
|
|
|
#ifndef NDEBUG
|
|
static void gc_poison_region(void *start, size_t size, value_t tag)
|
|
{
|
|
size_t count = size / GC_ALIGNMENT;
|
|
object_t *obj = (object_t*)start;
|
|
|
|
while (count--)
|
|
*obj++ = (object_t){ .tag = tag, .forward = tag };
|
|
}
|
|
#endif
|
|
|
|
/****************************** Gen-0 Collector *****************************/
|
|
|
|
/* These private variables are exported ONLY for use by is_gen0_object(). */
|
|
char *gc_gen0_range;
|
|
size_t gc_gen0_size;
|
|
|
|
static char *gc_gen0_free_ptr;
|
|
static char *gc_gen0_range_end;
|
|
|
|
/* Used to signal that Gen-0 pass has been obviated by Gen-1 collection. */
|
|
static jmp_buf gc_gen0_end_ctx;
|
|
|
|
static inline size_t gc_gen0_free_space(void)
|
|
{
|
|
return gc_gen0_range_end - gc_gen0_free_ptr;
|
|
}
|
|
|
|
static void gc_gen0_init(size_t gen0_size)
|
|
{
|
|
assert(gen0_size >= GC_ALIGNMENT);
|
|
|
|
gc_gen0_size = gen0_size;
|
|
gc_gen0_range = (char*)malloc(gc_gen0_size);
|
|
release_assert(gc_gen0_range);
|
|
|
|
gc_gen0_free_ptr = gc_gen0_range;
|
|
gc_gen0_range_end = gc_gen0_range + gc_gen0_size;
|
|
}
|
|
|
|
static void collect_gen0_garbage(void)
|
|
{
|
|
if (gc_enabled)
|
|
{
|
|
#ifndef NO_STATS
|
|
size_t initial_free_space;
|
|
#ifndef NO_TIMING_STATS
|
|
struct timespec start_time;
|
|
clock_gettime(TIMING_CLOCK, &start_time);
|
|
#endif
|
|
initial_free_space = gc_gen0_free_space() + gc_gen1_free_space();
|
|
#endif
|
|
|
|
debug(("Performing Gen-0 garbage collection pass...\n"));
|
|
|
|
assert(!gc_in_gen0_collection);
|
|
assert(!gc_in_gen1_collection);
|
|
|
|
/* If we trigger a Gen-1 collection at any point then we are done. */
|
|
/* Full collection will pull in any current Gen-0 objects. */
|
|
if (setjmp(gc_gen0_end_ctx) == 0)
|
|
{
|
|
char *object_ptr = gc_gen1_free_ptr;
|
|
const size_t used_bytes = gc_gen1_free_ptr - gc_gen1_ranges[gc_gen1_current_range];
|
|
const int current_blocks = (used_bytes + GC_DIRTY_BLOCK_SIZE - 1) / GC_DIRTY_BLOCK_SIZE;
|
|
const int current_block_groups = (current_blocks + 31) / 32;
|
|
int group;
|
|
|
|
gc_in_gen0_collection = true;
|
|
|
|
/* 1. Transfer Gen-0 roots (ignore Gen-1). */
|
|
transfer_roots();
|
|
|
|
/* 2. Locate and transfer Gen-0 references from dirty Gen-1 blocks. */
|
|
for (group = 0; group < current_block_groups; ++group)
|
|
{
|
|
uint32_t bits = gc_gen1_dirty_bits[group];
|
|
|
|
if (bits)
|
|
{
|
|
int block;
|
|
|
|
for (block = group * 32; bits; bits >>= 1, ++block)
|
|
{
|
|
if (bits & 1)
|
|
{
|
|
/* Find first object in the block */
|
|
char *block_obj = gc_gen1_block_starts[block];
|
|
char *block_end = gc_gen1_ranges[gc_gen1_current_range]
|
|
+ ((block+1) * GC_DIRTY_BLOCK_SIZE);
|
|
|
|
assert(block_obj && (gc_gen1_block_of(block_obj) == block));
|
|
|
|
/* For each object in block: transfer children */
|
|
do {
|
|
block_obj += gc_align(transfer_children((object_t*)block_obj));
|
|
assert(gc_gen1_range_of(block_obj) == gc_gen1_current_range);
|
|
} while (block_obj < block_end);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
gc_gen1_clear_dirty_bits();
|
|
|
|
/* Transfer Gen-0 children of objects newly moved to Gen-1 */
|
|
while (object_ptr < gc_gen1_free_ptr)
|
|
{
|
|
object_ptr += gc_align(transfer_children((object_t*)object_ptr));
|
|
}
|
|
|
|
/* These have to be examined after normal reachability has been determined */
|
|
process_weak_boxes();
|
|
process_wills();
|
|
|
|
/*
|
|
* Keep transferring until no more objects in the new range refer to the old one.
|
|
* This is so that values which are otherwise unreachable, but have finalizers which
|
|
* may be able to reach them, are not collected prematurely. process_wills() transfers
|
|
* the value of any will newly placed on the active list. Note that these values may
|
|
* be finalized in any order, and that any weak references have already been cleared.
|
|
*/
|
|
while (object_ptr < gc_gen1_free_ptr)
|
|
{
|
|
object_ptr += gc_align(transfer_children((object_t*)object_ptr));
|
|
}
|
|
|
|
update_weak_box_list();
|
|
|
|
#ifndef NDEBUG
|
|
/* Clear old range, to make it easier to detect bugs. */
|
|
gc_poison_region(gc_gen0_range, gc_gen0_size, GC_GEN0_POISON);
|
|
#endif
|
|
|
|
/* 4. Reset Gen-0 range to 'empty' state. */
|
|
gc_gen0_free_ptr = gc_gen0_range;
|
|
|
|
#ifndef NO_STATS
|
|
#ifndef NO_TIMING_STATS
|
|
{
|
|
struct timespec end_time;
|
|
nsec_t nsec;
|
|
|
|
clock_gettime(TIMING_CLOCK, &end_time);
|
|
|
|
nsec = (end_time.tv_sec - start_time.tv_sec) * 1000000000LL;
|
|
nsec += (end_time.tv_nsec - start_time.tv_nsec);
|
|
|
|
gc_stats.total_ns += nsec;
|
|
|
|
if (nsec > gc_stats.max_ns)
|
|
gc_stats.max_ns = nsec;
|
|
}
|
|
#endif
|
|
gc_stats.total_freed -= initial_free_space;
|
|
gc_stats.total_freed += gc_gen0_free_space();
|
|
gc_stats.total_freed += gc_gen1_free_space();
|
|
++gc_stats.gen0_passes;
|
|
#endif
|
|
}
|
|
|
|
gc_in_gen0_collection = false;
|
|
}
|
|
}
|
|
|
|
void *gc_alloc(size_t nbytes)
|
|
{
|
|
nbytes = gc_align(nbytes);
|
|
|
|
assert(!gc_in_gen0_collection);
|
|
assert(!gc_in_gen1_collection);
|
|
|
|
if (nbytes >= gc_gen0_size)
|
|
{
|
|
//debug(("Allocating directly from Gen-0...\n"));
|
|
return gc_alloc_gen1(nbytes);
|
|
}
|
|
else
|
|
{
|
|
if (nbytes > gc_gen0_free_space())
|
|
{
|
|
if (gc_enabled)
|
|
collect_gen0_garbage();
|
|
else
|
|
return gc_alloc_gen1(nbytes);
|
|
}
|
|
|
|
assert(nbytes <= gc_gen0_free_space());
|
|
|
|
{
|
|
void *const p = gc_gen0_free_ptr;
|
|
gc_gen0_free_ptr += nbytes;
|
|
return p;
|
|
}
|
|
}
|
|
}
|
|
|
|
/****************************** Gen-1 Collector *****************************/
|
|
|
|
static int gc_gen1_range_of(void *object)
|
|
{
|
|
const char *const ptr = (char*)object;
|
|
|
|
if ((ptr >= gc_gen1_ranges[0]) && (ptr < (gc_gen1_ranges[0] + gc_gen1_max_size)))
|
|
return 0;
|
|
else if ((ptr >= gc_gen1_ranges[1]) && (ptr < (gc_gen1_ranges[1] + gc_gen1_max_size)))
|
|
return 1;
|
|
else
|
|
return -1;
|
|
}
|
|
|
|
static inline bool gc_object_has_moved(value_t v)
|
|
{
|
|
return is_broken_heart(v) &&
|
|
(gc_gen1_range_of(_get_object(_get_object(v)->forward)) == gc_gen1_current_range);
|
|
}
|
|
|
|
/* Only useful AFTER all reachable objects have been processed. */
|
|
static inline bool gc_object_left_behind(value_t v)
|
|
{
|
|
/* Must provide a reference to the original location, not the new one (if moved). */
|
|
assert(!is_object(v) ||
|
|
is_gen0_object(v) ||
|
|
(gc_gen1_range_of(_get_object(v)) != gc_gen1_current_range));
|
|
|
|
return is_object(v) &&
|
|
(gc_in_gen1_collection || is_gen0_object(v)) &&
|
|
(!is_broken_heart(v) || (gc_gen1_range_of(_get_object(_get_object(v)->forward)) !=
|
|
gc_gen1_current_range));
|
|
}
|
|
|
|
static void gc_gen1_init(size_t min_size, size_t max_size)
|
|
{
|
|
release_assert(min_size <= ((max_size+1)/2));
|
|
|
|
gc_gen1_ranges[0] = (char*)malloc(max_size);
|
|
gc_gen1_ranges[1] = (char*)malloc(max_size);
|
|
|
|
release_assert(gc_gen1_ranges[0] && gc_gen1_ranges[1]);
|
|
|
|
gc_gen1_current_range = 0;
|
|
gc_gen1_free_ptr = gc_gen1_ranges[gc_gen1_current_range];
|
|
|
|
gc_gen1_min_size = min_size;
|
|
gc_gen1_max_size = max_size;
|
|
gc_gen1_soft_limit = 2*min_size;
|
|
gc_gen1_range_end = gc_gen1_free_ptr + gc_gen1_soft_limit;
|
|
|
|
gc_gen1_max_blocks = ((size_t)2 << 30) / GC_DIRTY_BLOCK_SIZE;
|
|
|
|
gc_gen1_dirty_bits = (uint32_t*)calloc((gc_gen1_max_blocks + 31) / 32, sizeof(uint32_t));
|
|
release_assert(gc_gen1_dirty_bits);
|
|
|
|
gc_gen1_block_starts = (char**)calloc(gc_gen1_max_blocks, sizeof(char*));
|
|
release_assert(gc_gen1_block_starts);
|
|
}
|
|
|
|
static void gc_gen1_clear_dirty_bits(void)
|
|
{
|
|
memset(gc_gen1_dirty_bits, 0, sizeof(uint32_t) * ((gc_gen1_max_blocks + 31) / 32));
|
|
}
|
|
|
|
static void *gc_alloc_gen1(size_t nbytes)
|
|
{
|
|
size_t min_free;
|
|
|
|
min_free = nbytes = gc_align(nbytes);
|
|
|
|
if (!gc_in_gen1_collection)
|
|
min_free += gc_gen0_size;
|
|
|
|
if (gc_gen1_free_space() < min_free)
|
|
collect_gen1_garbage(nbytes);
|
|
|
|
assert(nbytes <= gc_gen1_free_space());
|
|
|
|
{
|
|
void *const p = gc_gen1_free_ptr;
|
|
const size_t block = gc_gen1_block_of(p);
|
|
|
|
if (!gc_gen1_block_starts[block])
|
|
gc_gen1_block_starts[block] = (char*)p;
|
|
|
|
gc_gen1_free_ptr += nbytes;
|
|
return p;
|
|
}
|
|
}
|
|
|
|
static void transfer_object(value_t *value)
|
|
{
|
|
/* During Gen-0 collection pass, leave Gen-1 objects alone. Always ignore non-objects. */
|
|
if (is_object(*value) && (gc_in_gen1_collection || is_gen0_object(*value)))
|
|
{
|
|
object_t *obj = _get_object(*value);
|
|
size_t nbytes;
|
|
void *newobj;
|
|
|
|
assert(is_gen0_object(*value) ||
|
|
(gc_gen1_range_of(obj) == gc_gen1_other_range()));
|
|
|
|
if (obj->tag == BROKEN_HEART)
|
|
{
|
|
if (gc_gen1_range_of(_get_object(obj->forward)) != gc_gen1_current_range)
|
|
{
|
|
/* Gen-0 object was transferred into old range; needs to move to current range */
|
|
transfer_object(&obj->forward);
|
|
}
|
|
|
|
assert(gc_gen1_range_of(_get_object(obj->forward)) == gc_gen1_current_range);
|
|
|
|
/* Object has already been moved; just update the reference */
|
|
*value = obj->forward;
|
|
return;
|
|
}
|
|
|
|
switch (obj->tag)
|
|
{
|
|
case TYPE_TAG_BOX:
|
|
nbytes = sizeof(box_t);
|
|
break;
|
|
case TYPE_TAG_VECTOR:
|
|
nbytes = VECTOR_BYTES(((const vector_t*)obj)->size);
|
|
break;
|
|
case TYPE_TAG_BYTESTR:
|
|
nbytes = BYTESTR_BYTES(((const byte_string_t*)obj)->size);
|
|
break;
|
|
case TYPE_TAG_STRUCT:
|
|
nbytes = STRUCT_BYTES(((const struct_t*)obj)->nslots);
|
|
break;
|
|
case TYPE_TAG_WEAK_BOX:
|
|
nbytes = sizeof(weak_box_t);
|
|
break;
|
|
case TYPE_TAG_WILL:
|
|
nbytes = sizeof(will_t);
|
|
break;
|
|
case TYPE_TAG_FLOAT:
|
|
nbytes = sizeof(float_object_t);
|
|
break;
|
|
case TYPE_TAG_BUILTIN:
|
|
nbytes = sizeof(builtin_fn_object_t);
|
|
break;
|
|
default: /* pair */
|
|
nbytes = sizeof(pair_t);
|
|
break;
|
|
}
|
|
|
|
newobj = gc_alloc_gen1(nbytes);
|
|
memcpy(newobj, obj, nbytes);
|
|
|
|
/* Keep the original tag bits (pair or object) */
|
|
obj->tag = BROKEN_HEART;
|
|
*value = obj->forward = (object_value(newobj) & ~2) | (*value & 2);
|
|
}
|
|
}
|
|
|
|
static size_t transfer_vector(vector_t *vec)
|
|
{
|
|
assert(vec->tag == TYPE_TAG_VECTOR);
|
|
|
|
for (size_t i = 0; i < vec->size; ++i)
|
|
transfer_object(&vec->elements[i]);
|
|
|
|
return VECTOR_BYTES(vec->size);
|
|
}
|
|
|
|
static size_t transfer_struct(struct_t *s)
|
|
{
|
|
assert(s->tag == TYPE_TAG_STRUCT);
|
|
|
|
transfer_object(&s->type);
|
|
|
|
for (size_t i = 0; i < s->nslots; ++i)
|
|
transfer_object(&s->slots[i]);
|
|
|
|
return STRUCT_BYTES(s->nslots);
|
|
}
|
|
|
|
static size_t transfer_box(box_t *b)
|
|
{
|
|
transfer_object(&b->value);
|
|
return sizeof(box_t);
|
|
}
|
|
|
|
static size_t transfer_pair(pair_t *p)
|
|
{
|
|
transfer_object(&p->car);
|
|
transfer_object(&p->cdr);
|
|
return sizeof(pair_t);
|
|
}
|
|
|
|
static size_t transfer_will(will_t *w)
|
|
{
|
|
assert(w->tag == TYPE_TAG_WILL);
|
|
|
|
transfer_object(&w->finalizer);
|
|
|
|
/* Weak boxes are discarded when there are no other references,
|
|
* but wills need to remain until their finalizers are invoked. */
|
|
transfer_object(&w->next);
|
|
|
|
return sizeof(will_t);
|
|
}
|
|
|
|
static size_t transfer_children(object_t *obj)
|
|
{
|
|
switch (obj->tag)
|
|
{
|
|
case TYPE_TAG_BOX:
|
|
return transfer_box((box_t*)obj);
|
|
case TYPE_TAG_VECTOR:
|
|
return transfer_vector((vector_t*)obj);
|
|
case TYPE_TAG_BYTESTR:
|
|
return BYTESTR_BYTES(((const byte_string_t*)obj)->size);
|
|
case TYPE_TAG_STRUCT:
|
|
return transfer_struct((struct_t*)obj);
|
|
case TYPE_TAG_WEAK_BOX:
|
|
return sizeof(weak_box_t);
|
|
case TYPE_TAG_WILL:
|
|
return transfer_will((will_t*)obj);
|
|
case TYPE_TAG_FLOAT:
|
|
return sizeof(float_object_t);
|
|
case TYPE_TAG_BUILTIN:
|
|
return sizeof(builtin_fn_object_t);
|
|
default: /* pair */
|
|
return transfer_pair((pair_t*)obj);
|
|
}
|
|
}
|
|
|
|
static void swap_gen1_gc_ranges(void)
|
|
{
|
|
gc_gen1_current_range = gc_gen1_other_range();
|
|
gc_gen1_free_ptr = gc_gen1_ranges[gc_gen1_current_range];
|
|
gc_gen1_range_end = gc_gen1_free_ptr + gc_gen1_soft_limit;
|
|
}
|
|
|
|
static void transfer_roots(void)
|
|
{
|
|
/* Transfer registered GC roots */
|
|
for (gc_root_t *root = gc_root_list.next; root != &gc_root_list; root = root->next)
|
|
transfer_object(&root->value);
|
|
|
|
/* Ensure pending will list is transferred */
|
|
transfer_object(&gc_will_list);
|
|
|
|
/* The values associated with active wills are also roots */
|
|
for (value_t will = gc_will_active_list; !is_nil(will); will = _get_will(will)->next)
|
|
transfer_object(&get_will(will)->value);
|
|
|
|
/* Ensure active list itself is transferred */
|
|
transfer_object(&gc_will_active_list);
|
|
}
|
|
|
|
static void process_weak_boxes(void)
|
|
{
|
|
value_t wb = gc_weak_box_list;
|
|
|
|
while (!is_nil(wb))
|
|
{
|
|
weak_box_t *box;
|
|
|
|
if (gc_object_has_moved(wb))
|
|
{
|
|
/* Box has been moved; get a pointer to the new location, but don't update list yet. */
|
|
value_t fw = _get_object(wb)->forward;
|
|
assert(is_weak_box(fw));
|
|
box = _get_weak_box(fw);
|
|
}
|
|
else
|
|
{
|
|
/* Box hasn't been moved. Could be Gen-0 pass, or may live on as the value of a will. */
|
|
assert(is_weak_box(wb));
|
|
box = _get_weak_box(wb);
|
|
}
|
|
|
|
if (gc_object_left_behind(box->value))
|
|
{
|
|
/* The value in the box is an unreachable object; change to #f. */
|
|
|
|
/*
|
|
* NOTE: An object is considered unreachable via weak box when it could be finalized, even
|
|
* though it will be kept alive until any finalizers are removed from the 'active' list.
|
|
* The finalizer(s) may restore the object to a reachable state, in which case it will not
|
|
* be collected--but the weak reference will remain broken.
|
|
*
|
|
* Restoring references to otherwise GC'able objects is not recommended.
|
|
*
|
|
* The only known alternative would have been to invoke the finalizer while other objects
|
|
* may still be able to access the object (and create new references) via the weak box.
|
|
*/
|
|
|
|
box->value = FALSE_VALUE;
|
|
}
|
|
else if (gc_object_has_moved(box->value))
|
|
{
|
|
/* The value in the box is reachable; update w/ new location. */
|
|
box->value = _get_object(box->value)->forward;
|
|
}
|
|
|
|
/* Move on to this box's 'next' pointer */
|
|
wb = box->next;
|
|
}
|
|
}
|
|
|
|
/* Precondition: The wills themselves, and their finalizers,
|
|
* have already been transferred (recursively). */
|
|
static void process_wills(void)
|
|
{
|
|
/*
|
|
* Was value transferred (broken heart), and thus reachable?
|
|
* Yes ==> update value.
|
|
* No ==> transfer value and move will to active list.
|
|
*/
|
|
value_t *will = &gc_will_list;
|
|
|
|
while (!is_nil(*will))
|
|
{
|
|
will_t *w = get_will(*will);
|
|
|
|
if (gc_object_left_behind(w->value))
|
|
{
|
|
/*
|
|
* The will is associated with an unreachable object; activate it.
|
|
*/
|
|
|
|
/* First, ensure that the value remains reachable for the finalizer. */
|
|
transfer_object(&w->value);
|
|
|
|
/* Remove the will from the 'pending' list. */
|
|
*will = w->next;
|
|
|
|
/* Insert the will into the 'active' list. */
|
|
w->next = gc_will_active_list;
|
|
gc_will_active_list = object_value(w);
|
|
}
|
|
else
|
|
{
|
|
/* The value associated with the will is still reachable; update w/ new location. */
|
|
if (gc_object_has_moved(w->value))
|
|
{
|
|
w->value = _get_object(w->value)->forward;
|
|
}
|
|
|
|
/* Move on to this will's 'next' pointer */
|
|
will = &w->next;
|
|
}
|
|
}
|
|
}
|
|
|
|
static void update_weak_box_list(void)
|
|
{
|
|
value_t *wb = &gc_weak_box_list;
|
|
|
|
while (!is_nil(*wb))
|
|
{
|
|
if (gc_object_left_behind(*wb))
|
|
{
|
|
/* Box is no longer reachable; remove it from the list by updating 'next' pointer. */
|
|
assert(is_weak_box(*wb));
|
|
*wb = _get_weak_box(*wb)->next;
|
|
}
|
|
else
|
|
{
|
|
/* The box itself is reachable; need to update 'next' pointer to new location */
|
|
if (gc_object_has_moved(*wb))
|
|
{
|
|
*wb = _get_object(*wb)->forward;
|
|
}
|
|
|
|
/* Move on to next box's 'next' pointer */
|
|
assert(is_weak_box(*wb));
|
|
wb = &_get_weak_box(*wb)->next;
|
|
}
|
|
}
|
|
}
|
|
|
|
#define GC_DEFLATE_SIZE (64*1024)
|
|
|
|
static void update_soft_limit(size_t min_free)
|
|
{
|
|
size_t bytes_used = gc_gen1_free_ptr - gc_gen1_ranges[gc_gen1_current_range];
|
|
size_t min_limit = bytes_used + min_free;
|
|
size_t new_limit = 2 * min_limit;
|
|
|
|
if (gc_gen1_soft_limit > GC_DEFLATE_SIZE)
|
|
{
|
|
size_t deflate_limit = gc_gen1_soft_limit - GC_DEFLATE_SIZE;
|
|
|
|
if (new_limit < deflate_limit)
|
|
new_limit = deflate_limit;
|
|
}
|
|
|
|
if (new_limit < gc_gen1_min_size)
|
|
new_limit = gc_gen1_min_size;
|
|
else if (new_limit > gc_gen1_max_size)
|
|
new_limit = gc_gen1_max_size;
|
|
|
|
gc_gen1_soft_limit = new_limit;
|
|
|
|
/* Update end of range to reflect new limit */
|
|
gc_gen1_range_end = gc_gen1_ranges[gc_gen1_current_range] + gc_gen1_soft_limit;
|
|
|
|
#ifndef NO_STATS
|
|
if (gc_gen1_soft_limit > gc_stats.high_water)
|
|
{
|
|
gc_stats.high_water = gc_gen1_soft_limit;
|
|
}
|
|
#endif
|
|
}
|
|
|
|
static size_t gc_gen1_block_of(void *obj)
|
|
{
|
|
const intptr_t offset = (uintptr_t)obj
|
|
- (uintptr_t)gc_gen1_ranges[gc_gen1_current_range];
|
|
|
|
return (offset & (((uintptr_t)2 << 30) - 1)) / GC_DIRTY_BLOCK_SIZE;
|
|
}
|
|
|
|
void _gc_mark_updated_gen1_object(value_t v)
|
|
{
|
|
const size_t block = gc_gen1_block_of(_get_object(v));
|
|
assert(is_object(v) && !is_gen0_object(v) && gc_gen1_block_starts[block]);
|
|
gc_gen1_dirty_bits[block / 32] |= (1UL << (block % 32));
|
|
}
|
|
|
|
static void _out_of_memory(void) __attribute__ ((noreturn));
|
|
static void _out_of_memory(void)
|
|
{
|
|
out_of_memory();
|
|
abort();
|
|
}
|
|
|
|
static void collect_gen1_garbage(size_t min_free)
|
|
{
|
|
bool was_in_gen0_collection = gc_in_gen0_collection;
|
|
bool collected_garbage = false;
|
|
|
|
/* If Gen-1 free space falls below used portion of Gen-0, chaos may ensue. */
|
|
assert(gc_gen1_free_space() >= (gc_gen0_free_ptr - gc_gen0_range));
|
|
min_free += gc_gen0_size;
|
|
|
|
if (gc_enabled)
|
|
{
|
|
char *object_ptr;
|
|
|
|
#ifndef NO_STATS
|
|
size_t initial_free_space = gc_gen0_free_space() + gc_gen1_free_space();
|
|
#ifndef NO_TIMING_STATS
|
|
struct timespec start_time;
|
|
clock_gettime(TIMING_CLOCK, &start_time);
|
|
#endif
|
|
#endif
|
|
|
|
debug(("Performing Gen-1 garbage collection pass...\n"));
|
|
|
|
gc_enabled = false;
|
|
gc_in_gen0_collection = false;
|
|
gc_in_gen1_collection = true;
|
|
|
|
gc_gen1_clear_dirty_bits();
|
|
swap_gen1_gc_ranges();
|
|
|
|
/* Record the start of each Gen-1 block as objects are moved to the new range. */
|
|
memset(gc_gen1_block_starts, 0, gc_gen1_max_blocks * sizeof(char*));
|
|
|
|
/* New "current" range is initially empty, old one is full */
|
|
object_ptr = gc_gen1_free_ptr;
|
|
|
|
/* Prime the pump */
|
|
transfer_roots();
|
|
|
|
/* Keep transferring until no more objects in the new range refer to the old one,
|
|
* other than pending wills and weak boxes. */
|
|
while (object_ptr < gc_gen1_free_ptr)
|
|
{
|
|
object_ptr += gc_align(transfer_children((object_t*)object_ptr));
|
|
assert(gc_gen1_range_of(object_ptr) == gc_gen1_current_range);
|
|
}
|
|
|
|
/* These have to be examined after normal reachability has been determined */
|
|
process_weak_boxes();
|
|
process_wills();
|
|
|
|
/* Keep transferring until no more objects in the new range refer to the old one.
|
|
* This is so that values which are otherwise unreachable, but have finalizers which
|
|
* may be able to reach them, are not collected prematurely. process_wills() transfers
|
|
* the value of any will newly placed on the active list. Note that these values may
|
|
* be finalized in any order, and that any weak references have already been cleared. */
|
|
while (object_ptr < gc_gen1_free_ptr)
|
|
{
|
|
object_ptr += gc_align(transfer_children((object_t*)object_ptr));
|
|
assert(gc_gen1_range_of(object_ptr) == gc_gen1_current_range);
|
|
}
|
|
|
|
update_weak_box_list();
|
|
|
|
#ifndef NDEBUG
|
|
/* Clear old range, to make it easier to detect bugs. */
|
|
gc_poison_region(gc_gen1_ranges[gc_gen1_other_range()], gc_gen1_soft_limit, GC_GEN1_POISON);
|
|
gc_poison_region(gc_gen0_range, gc_gen0_size, GC_GEN0_POISON);
|
|
#endif
|
|
|
|
/*
|
|
* Gen-0 should be empty at this point; all active objects
|
|
* have been moved to the Gen-1 memory region.
|
|
*/
|
|
|
|
gc_gen0_free_ptr = gc_gen0_range;
|
|
collected_garbage = true;
|
|
|
|
//debug(("Finished collection with %d bytes to spare (out of %d bytes).\n", gc_gen1_free_space(), gc_gen1_soft_limit));
|
|
|
|
gc_in_gen1_collection = false;
|
|
gc_enabled = true;
|
|
|
|
#ifndef NO_STATS
|
|
#ifndef NO_TIMING_STATS
|
|
{
|
|
struct timespec end_time;
|
|
nsec_t nsec;
|
|
|
|
clock_gettime(TIMING_CLOCK, &end_time);
|
|
|
|
nsec = (end_time.tv_sec - start_time.tv_sec) * 1000000000LL;
|
|
nsec += (end_time.tv_nsec - start_time.tv_nsec);
|
|
|
|
gc_stats.total_ns += nsec;
|
|
|
|
if (nsec > gc_stats.max_ns)
|
|
gc_stats.max_ns = nsec;
|
|
}
|
|
#endif
|
|
gc_stats.total_freed -= initial_free_space;
|
|
gc_stats.total_freed += gc_gen0_free_space();
|
|
gc_stats.total_freed += gc_gen1_free_space();
|
|
++gc_stats.gen1_passes;
|
|
#endif
|
|
}
|
|
|
|
update_soft_limit(min_free);
|
|
|
|
if (gc_gen1_free_space() < min_free)
|
|
{
|
|
size_t bytes_used = gc_gen1_free_ptr - gc_gen1_ranges[gc_gen1_current_range];
|
|
size_t need_bytes = bytes_used + min_free + gc_gen0_size;
|
|
|
|
/* If GC is disabled then we can't move anything, so reallocating is impossible. */
|
|
if (!gc_enabled)
|
|
_out_of_memory();
|
|
|
|
/*
|
|
* Try to get more memory from the C runtime.
|
|
*/
|
|
|
|
debug(("Ran out of free memory; will try to allocate more...\n"));
|
|
|
|
do {
|
|
release_assert(gc_gen1_max_size < (SIZE_MAX/2));
|
|
gc_gen1_max_size *= 2;
|
|
} while (gc_gen1_max_size < need_bytes);
|
|
|
|
/* Reallocate the unused space. */
|
|
{
|
|
char *unused_range = gc_gen1_ranges[gc_gen1_other_range()];
|
|
gc_gen1_ranges[gc_gen1_other_range()] = (char*)malloc(gc_gen1_max_size);
|
|
free(unused_range);
|
|
}
|
|
|
|
/* See if reallocation succeeded. */
|
|
if (!gc_gen1_ranges[gc_gen1_other_range()])
|
|
_out_of_memory();
|
|
|
|
/* Move everything into the newly enlarged space.
|
|
* Will update the soft-limit. */
|
|
collect_gen1_garbage(0);
|
|
|
|
/* Reallocate the other space, now unused. */
|
|
free(gc_gen1_ranges[gc_gen1_other_range()]);
|
|
gc_gen1_ranges[gc_gen1_other_range()] = (char*)malloc(gc_gen1_max_size);
|
|
|
|
/* Ensure second reallocation succeeded. */
|
|
if (!gc_gen1_ranges[gc_gen1_other_range()])
|
|
_out_of_memory();
|
|
}
|
|
|
|
/* If Gen-1 was invoked within Gen-0, skip the rest: Gen-0 is empty, we're done. */
|
|
if (was_in_gen0_collection && collected_garbage)
|
|
longjmp(gc_gen0_end_ctx, 1);
|
|
}
|
|
|
|
void collect_garbage(size_t min_free)
|
|
{
|
|
bool was_enabled = set_gc_enabled(true);
|
|
collect_gen1_garbage(min_free);
|
|
set_gc_enabled(was_enabled);
|
|
}
|
|
|
|
bool set_gc_enabled(bool enable)
|
|
{
|
|
bool was_enabled = gc_enabled;
|
|
gc_enabled = enable;
|
|
return was_enabled;
|
|
}
|
|
|
|
bool are_finalizers_pending(void)
|
|
{
|
|
return !is_nil(gc_will_active_list);
|
|
}
|
|
|
|
/* Finalizer can be registered as #f, but value must be an object.
|
|
* Returning with value == #f means there are no more finalizers. */
|
|
void get_next_finalizer(value_t *value, value_t *finalizer)
|
|
{
|
|
assert(value && finalizer);
|
|
|
|
if (is_nil(gc_will_active_list))
|
|
{
|
|
*value = *finalizer = FALSE_VALUE;
|
|
}
|
|
else
|
|
{
|
|
will_t *w = get_will(gc_will_active_list);
|
|
|
|
*value = w->value;
|
|
*finalizer = w->finalizer;
|
|
|
|
/* Remove this finalizer from the list -- up to caller to keep values reachable. */
|
|
gc_will_active_list = w->next;
|
|
}
|
|
}
|
|
|
|
void _release_assert(bool expr, const char *str, const char *file, int line)
|
|
{
|
|
if (!expr)
|
|
{
|
|
fprintf(stderr, "ERROR: Invalid state detected in %s, line %d.\n"
|
|
"Assertion failed: %s\n",
|
|
file, line, str);
|
|
|
|
abort();
|
|
}
|
|
}
|
|
|
|
typedef struct seen_value
|
|
{
|
|
value_t value;
|
|
struct seen_value *prev;
|
|
} seen_value_t;
|
|
|
|
static void _fprint_value(FILE *f, value_t v, seen_value_t *seen)
|
|
{
|
|
seen_value_t new_seen = { v, seen };
|
|
int depth = 0;
|
|
|
|
if (is_object(v) && !(is_float(v) || is_byte_string(v) || is_builtin_fn(v)))
|
|
{
|
|
for (seen_value_t *sv = seen; sv; sv = sv->prev)
|
|
{
|
|
if (v == sv->value)
|
|
{
|
|
fputs("#<cycle>", f);
|
|
return;
|
|
}
|
|
|
|
if (++depth >= 3)
|
|
{
|
|
fputs("...", f);
|
|
return;
|
|
}
|
|
}
|
|
}
|
|
|
|
if (v == NIL)
|
|
{
|
|
fputs("nil", f);
|
|
}
|
|
else if (v == FALSE_VALUE)
|
|
{
|
|
fputs("#f", f);
|
|
}
|
|
else if (v == TRUE_VALUE)
|
|
{
|
|
fputs("#t", f);
|
|
}
|
|
else if (v == UNDEFINED)
|
|
{
|
|
fputs("#<undefined>", f);
|
|
}
|
|
else if (is_fixnum(v))
|
|
{
|
|
fprintf(f, "%d", (int)get_fixnum(v));
|
|
}
|
|
else if (is_box(v))
|
|
{
|
|
fputs("#&", f);
|
|
_fprint_value(f, _get_box(v)->value, &new_seen);
|
|
}
|
|
else if (is_pair(v))
|
|
{
|
|
fputc('(', f);
|
|
|
|
_fprint_value(f, _get_pair(v)->car, &new_seen);
|
|
v = _get_pair(v)->cdr;
|
|
|
|
while (is_pair(v))
|
|
{
|
|
fputc(' ', f);
|
|
_fprint_value(f, _get_pair(v)->car, &new_seen);
|
|
v = _get_pair(v)->cdr;
|
|
}
|
|
|
|
if (v != NIL)
|
|
{
|
|
fputs(" . ", f);
|
|
_fprint_value(f, v, &new_seen);
|
|
}
|
|
|
|
fputc(')', f);
|
|
}
|
|
else if (is_vector(v))
|
|
{
|
|
fputs("#(", f);
|
|
|
|
for (size_t i = 0; i < _get_vector(v)->size; ++i)
|
|
{
|
|
if (i != 0) fputc(' ', f);
|
|
_fprint_value(f, _get_vector(v)->elements[i], &new_seen);
|
|
}
|
|
|
|
fputc(')', f);
|
|
}
|
|
else if (is_byte_string(v))
|
|
{
|
|
byte_string_t *str = _get_byte_string(v);
|
|
size_t written = 0;
|
|
|
|
fputc('"', f);
|
|
|
|
for (size_t i = 0; i < str->size; ++i)
|
|
{
|
|
int ch = str->bytes[i];
|
|
|
|
if (isprint(ch) && (ch != '\\') && (ch != '\"'))
|
|
{
|
|
fputc(str->bytes[i], f);
|
|
++written;
|
|
}
|
|
else
|
|
{
|
|
fprintf(f, "\\x%.2X", (int)str->bytes[i]);
|
|
written += 4;
|
|
}
|
|
|
|
if (written >= 20)
|
|
{
|
|
fputs("...", f);
|
|
break;
|
|
}
|
|
}
|
|
|
|
fputc('"', f);
|
|
}
|
|
else if (is_struct(v))
|
|
{
|
|
struct_t *meta = get_struct(_get_struct(v)->type);
|
|
byte_string_t *str = get_byte_string(meta->slots[0]);
|
|
|
|
fputs("#S(", f);
|
|
fwrite(str->bytes, str->size, 1, f);
|
|
|
|
for (size_t i = 0; i < _get_struct(v)->nslots; ++i)
|
|
{
|
|
fputc(' ', f);
|
|
_fprint_value(f, _get_struct(v)->slots[i], &new_seen);
|
|
}
|
|
|
|
fputc(')', f);
|
|
}
|
|
else if (is_weak_box(v))
|
|
{
|
|
fputs("#W&", f);
|
|
_fprint_value(f, _get_weak_box(v)->value, &new_seen);
|
|
}
|
|
else if (is_float(v))
|
|
{
|
|
fprintf(f, "%f", (double)_get_float(v));
|
|
}
|
|
else if (is_builtin_fn(v))
|
|
{
|
|
fputs("#<builtin>", f);
|
|
}
|
|
else
|
|
{
|
|
fputs("#<unknown>", f);
|
|
}
|
|
}
|
|
|
|
void fprint_value(FILE *f, value_t v)
|
|
{
|
|
_fprint_value(f, v, NULL);
|
|
}
|
|
|
|
void fprint_gc_stats(FILE *f)
|
|
{
|
|
if ((gc_stats.gen0_passes + gc_stats.gen1_passes) > 0)
|
|
{
|
|
const double total_time = gc_stats.total_ns / 1.0e9;
|
|
const double max_time = gc_stats.max_ns / 1.0e9;
|
|
|
|
fprintf(f, "GC: %lld bytes freed by %d+%d GCs in %0.6f sec => %0.3f MB/sec.\n",
|
|
gc_stats.total_freed,
|
|
gc_stats.gen0_passes,
|
|
gc_stats.gen1_passes,
|
|
total_time,
|
|
(gc_stats.total_freed / total_time) / (1024*1024));
|
|
|
|
fprintf(f, "GC: Avg. time was %0.6f sec, max %0.6f.\n",
|
|
(total_time / (gc_stats.gen0_passes + gc_stats.gen1_passes)), max_time);
|
|
|
|
fprintf(f, "GC: The soft-limit peaked at %d bytes out of %d allocated.\n",
|
|
gc_stats.high_water, gc_gen1_max_size);
|
|
}
|
|
else
|
|
{
|
|
fputs("GC: No garbage collection was performed.\n", f);
|
|
}
|
|
}
|
|
|
|
/* vim:set sw=2 expandtab: */
|