void* sly_gc_alloc(sly_store_t *S, size_t size)
{
void *ret;
/* allocating only word-multiple sized blocks */
assert(size % WSIZE == 0);
#ifdef SLY_DTRACE
if(SLY_GC_ALLOC_ENABLED()) {
SLY_GC_ALLOC(size);
}
#endif
if(S->capacity - S->size < size) {
/* not enough space, try to find some */
collect_garbage(S);
while(S->capacity - S->size < size) {
/* expand store until it fits */
if(expand_store(S) == 0) {
return NULL;
}
}
}
/* allocs from the from space */
ret = S->from_space + S->size;
S->size += size;
/* returned address must be word aligned */
assert((uintptr_t)ret % WSIZE == 0);
return ret;
}
static int expand_store(sly_store_t* S)
{
void *tmp;
size_t old_size, size;
old_size = S->capacity;
/* new size is 30% larger, word aligned */
size = old_size * 4 / 3;
size -= size % WSIZE;
#ifdef SLY_DTRACE
if(SLY_GC_RESIZE_ENABLED()) {
SLY_GC_RESIZE(old_size, size);
}
#endif
tmp = malloc(size * 2);
if(tmp == NULL) {
return 0;
} else {
S->capacity = size;
/* copy objects to new memory */
S->to_space = tmp;
collect_garbage(S);
/* fix pointers */
S->to_space = tmp + size;
free(S->os_address);
S->os_address = tmp;
return 1;
}
}
extern obj_t core_eval_cont(volatile obj_t cont,
volatile obj_t values,
obj_t handler)
{
eval_dyn_env = MAKE_RECORD(dyn_env, EMPTY_LIST, handler);
if (sigsetjmp(eval_sigrestart, 1)) {
/* On Linux, siglongjmp is 30X slower than longjmp. */
/* push exception... */
} else {
switch (setjmp(eval_restart)) {
case LT_THROWN:
{
cv_t ret = push_exception(cont, values);
cont = ret.cv_cont;
values = ret.cv_values;
}
break;
case LT_HEAP_FULL:
cont_root = cont;
values_root = values;
collect_garbage();
cont = cont_root;
values = values_root;
cont_root = make_uninitialized();
values_root = make_uninitialized();
break;
case LT_NO_EXCEPTION:
register_lowex_handler(handle_lowex);
break;
default:
assert(false);
}
}
while (!is_null(cont)) {
cv_t ret = cont_proc(cont)(cont, values);
cont = ret.cv_cont;
values = ret.cv_values;
COMMIT();
#if DEBUG_EVAL
int n = 0;
obj_t p;
for (p = cont; !is_null(p); p = cont_cont(p))
n++;
EVAL_LOG("values=%O cont depth=%d", values, n);
#endif
}
deregister_lowex_handler(handle_lowex);
eval_dyn_env = make_uninitialized();
EVAL_LOG("END values=%O", values);
assert(is_null(CDR(values)));
return CAR(values);
}
int main(int argc, char *argv[])
{
/* Declarations */
int c, option_index = 0;
struct option long_options[] =
{
{"interface", required_argument, 0, 'i'},
{"target-property", required_argument, 0, 't'},
{"delete-old", no_argument, 0, 'd'},
{"help", no_argument, 0, 'h'},
{"version", no_argument, 0, 'v'},
{0, 0, 0, 0}
};
char *interface = NULL;
gboolean delete_old = FALSE;
char *target_property = NULL;
/* Parse command-line options */
while((c = getopt_long(argc, argv, "dhv", long_options, &option_index)) != -1)
{
switch(c)
{
case 'i':
interface = optarg;
break;
case 't':
target_property = optarg;
break;
case 'd':
delete_old = TRUE;
break;
case 'h':
case '?':
print_usage(argv[0]);
return 0;
case 'v':
print_version(argv[0]);
return 0;
}
}
/* Validate options */
interface = check_interface_option(interface);
target_property = check_target_property_option(target_property);
if(optind >= argc)
{
fprintf(stderr, "An infrastructure Nix expression has to be specified!\n");
return 1;
}
else
return collect_garbage(interface, target_property, argv[optind], delete_old); /* Execute garbage collection operation */
}
void collect_garbage()
{
if (!chunks) return;
/* minor collection: */
mark_and_sweep_from_roots();
/* The minor collection above relies on having no references from
old object to new objects; this is not a general-purpose GC. If
such references were allowed, we'd have to add them as roots. */
/* move non-empty chunks to old generation: */
if (chunks) {
struct gc_chunk *prev_c = NULL, *next;
for (struct gc_chunk *c = chunks; c; c = next) {
next = c->next;
if (c->num_marked_nodes == 0) {
/* This chunk is empty, so free it */
raw_free(c->mem, NODES_PER_CHUNK * sizeof(struct gc_node));
raw_free(c, sizeof(struct gc_chunk));
if (!prev_c)
chunks = next;
} else {
/* Keep this chunk, now as an old-generation chunk */
num_gen1_chunks++;
if (prev_c)
prev_c->next = c;
prev_c = c;
}
c = next;
}
if (prev_c) {
prev_c->next = gen1_chunks;
gen1_chunks = chunks;
}
chunks = NULL;
free_list = NULL;
}
if (num_gen1_chunks >= (last_major_gen1_chunks * 2)) {
/* perform major collection by moving all old-generation
chunks back to the "new" generation, and GC again */
// printf("Major GC\n");
last_major_gen1_chunks = num_gen1_chunks;
chunks = gen1_chunks;
gen1_chunks = NULL;
num_gen1_chunks = 0;
collect_garbage();
}
}
enum pause_reason do_stuff(void)
{
struct thread *thread;
volatile int timer;
volatile bool do_select = true;
assert (!InInterpreter);
do {
if (do_select)
check_fds(false);
else
do_select = true;
PauseReason = pause_NoReason;
thread = thread_pick_next();
if (thread) {
timer = OPS_PER_TIME_SLICE;
InInterpreter = true;
set_interrupt_handler(set_pause_interrupted);
_setjmp(Catcher);
if (PauseReason == pause_NoReason)
while (timer-- > 0) {
#if SLOW_FUNCTION_POINTERS
if (thread->advance)
thread->advance(thread);
else
interpret_next_byte(thread);
#else
thread->advance(thread);
#endif
}
InInterpreter = false;
clear_interrupt_handler();
if (TimeToGC)
collect_garbage(false);
}
else if (all_threads() == NULL)
PauseReason = pause_NothingToRun;
else {
set_interrupt_handler(set_pause_interrupted);
check_fds(true);
do_select = false;
clear_interrupt_handler();
}
} while (PauseReason == pause_NoReason
|| PauseReason == pause_PickNewThread);
return PauseReason;
}
/*---------------------------------------------------------------------------*/
static int
remove_by_page(coffee_page_t page, int remove_log, int close_fds,
int gc_allowed)
{
struct file_header hdr;
int i;
read_header(&hdr, page);
if(!HDR_ACTIVE(hdr)) {
return -1;
}
if(remove_log && HDR_MODIFIED(hdr)) {
if(remove_by_page(hdr.log_page, !REMOVE_LOG, !CLOSE_FDS, !ALLOW_GC) < 0) {
return -1;
}
}
hdr.flags |= HDR_FLAG_OBSOLETE;
write_header(&hdr, page);
*gc_wait = 0;
/* Close all file descriptors that reference the removed file. */
if(close_fds) {
for(i = 0; i < COFFEE_FD_SET_SIZE; i++) {
if(coffee_fd_set[i].file != NULL && coffee_fd_set[i].file->page == page) {
coffee_fd_set[i].flags = COFFEE_FD_FREE;
}
}
}
for(i = 0; i < COFFEE_MAX_OPEN_FILES; i++) {
if(coffee_files[i].page == page) {
coffee_files[i].page = INVALID_PAGE;
coffee_files[i].references = 0;
coffee_files[i].max_pages = 0;
}
}
#if !COFFEE_EXTENDED_WEAR_LEVELLING
if(gc_allowed) {
collect_garbage(GC_RELUCTANT);
}
#endif
return 0;
}
/*---------------------------------------------------------------------------*/
static struct file *
reserve(const char *name, coffee_page_t pages,
int allow_duplicates, unsigned flags)
{
struct file_header hdr;
coffee_page_t page;
struct file *file;
COFFEE_WATCHDOG_STOP();
if(!allow_duplicates && find_file(name) != NULL) {
COFFEE_WATCHDOG_START();
return NULL;
}
page = find_contiguous_pages(pages);
if(page == INVALID_PAGE) {
if(*gc_wait) {
return NULL;
}
collect_garbage(GC_GREEDY);
page = find_contiguous_pages(pages);
if(page == INVALID_PAGE) {
COFFEE_WATCHDOG_START();
*gc_wait = 1;
return NULL;
}
}
memset(&hdr, 0, sizeof(hdr));
memcpy(hdr.name, name, sizeof(hdr.name) - 1);
hdr.max_pages = pages;
hdr.flags = HDR_FLAG_ALLOCATED | flags;
write_header(&hdr, page);
PRINTF("Coffee: Reserved %u pages starting from %u for file %s\n",
pages, page, name);
file = load_file(page, &hdr);
if(file != NULL) {
file->end = 0;
}
COFFEE_WATCHDOG_START();
return file;
}
bool
enqueue( queue *queue, void *data ) {
assert( queue != NULL );
assert( data != NULL );
queue_element *new_tail = malloc( sizeof( queue_element ) );
new_tail->data = data;
new_tail->next = NULL;
queue->tail->next = new_tail;
queue->tail = new_tail;
write_memory_barrier();
__sync_add_and_fetch( &queue->length, 1 );
collect_garbage( queue );
return true;
}
static int read_driver(const test_case_descriptor_t *tc)
{
int err_count = 0;
#if TEST_TRACE
printf("%s:%d read %ls\n", tc->tcd_file, tc->tcd_lineno, tc->tcd_input);
#endif
collect_garbage();
obj_t input = make_string_from_C_str(tc->tcd_input);
obj_t osip_sym = make_symbol_from_C_str(L"open-string-input-port");
obj_t read_sym = make_symbol_from_C_str(L"read");
obj_t expr = MAKE_LIST(read_sym, MAKE_LIST(osip_sym, input));
obj_t env = root_environment();
obj_t cont = make_cont4(c_eval, EMPTY_LIST, env, expr);
obj_t hname = make_symbol_from_C_str(L"test-handler");
obj_t handler = make_raw_procedure(c_test_handler, hname, env);
obj_t obj = core_eval_cont(cont, EMPTY_LIST, handler);
const size_t out_size = 100;
wchar_t actual[out_size + 1];
outstream_t *out = make_string_outstream(actual, out_size);
princ(obj, out);
delete_outstream(out);
size_t expected_bytes = sizeof (wchar_t) * (tc->tcd_expected_len + 1);
if (memcmp(actual, tc->tcd_expected, expected_bytes)) {
int i;
printf("%s:%d FAIL read test\n", tc->tcd_file, tc->tcd_lineno);
printf(" input = %ls\n", tc->tcd_input);
printf(" actual = %ls = {", actual);
for (i = 0; i <= tc->tcd_expected_len; i++)
printf("\\x%02x, ", actual[i]);
printf("};\n");
printf(" expected = %ls = {", tc->tcd_expected);
for (i = 0; i <= tc->tcd_expected_len; i++)
printf("\\x%02x, ", tc->tcd_expected[i]);
printf("};\n");
printf(" expected_len = %zd", tc->tcd_expected_len);
printf("\n");
err_count++;
}
return err_count;
}
static void tls_reload(rpc_t* rpc, void* ctx)
{
tls_domains_cfg_t* cfg;
str tls_domains_cfg_file;
tls_domains_cfg_file = cfg_get(tls, tls_cfg, config_file);
if (!tls_domains_cfg_file.s) {
rpc->fault(ctx, 500, "No TLS configuration file configured");
return;
}
/* Try to delete old configurations first */
collect_garbage();
cfg = tls_load_config(&tls_domains_cfg_file);
if (!cfg) {
rpc->fault(ctx, 500, "Error while loading TLS configuration file"
" (consult server log)");
return;
}
if (tls_fix_domains_cfg(cfg, &srv_defaults, &cli_defaults) < 0) {
rpc->fault(ctx, 500, "Error while fixing TLS configuration"
" (consult server log)");
goto error;
}
if (tls_check_sockets(cfg) < 0) {
rpc->fault(ctx, 500, "No server listening socket found for one of"
" TLS domains (consult server log)");
goto error;
}
DBG("TLS configuration successfuly loaded");
cfg->next = (*tls_domains_cfg);
*tls_domains_cfg = cfg;
return;
error:
tls_free_cfg(cfg);
}
void *allocate ( size_t sz, block_construction_locker_base *lock )
{
assert ( sz > 0 );
assert ( lock );
if ( m_current_heap_bytes >= m_next_collection_heap_size )
{
// It's time to collect.
collect_garbage ( NULL );
}
gc_object_generic_base *block = static_cast<gc_object_generic_base *> ( operator new ( sz /* + overhead? */ ) );
m_heap_blocks.insert ( std::make_pair ( block, blockinfo ( block, sz ) ) );
m_current_heap_bytes += sz;
// Keep this block from being collected during
// construction, before it has a chance to be
// assigned to a gc_ptr.
m_floating_blocks.insert ( block );
block_ref ( lock ) = block;
return block;
}
void CSpaceRestrictionManager::restrict (ALife::_OBJECT_ID id, shared_str out_restrictors, shared_str in_restrictors)
{
shared_str merged_out_restrictions = out_restrictors;
shared_str merged_in_restrictions = in_restrictors;
shared_str _default_out_restrictions = default_out_restrictions();
shared_str _default_in_restrictions = default_in_restrictions();
difference_restrictions (_default_out_restrictions,merged_in_restrictions);
difference_restrictions (_default_in_restrictions,merged_out_restrictions);
join_restrictions (merged_out_restrictions,_default_out_restrictions);
join_restrictions (merged_in_restrictions,_default_in_restrictions);
CLIENT_RESTRICTIONS::iterator I = m_clients->find(id);
VERIFY2 ((m_clients->end() == I) || !(*I).second.m_restriction || !(*I).second.m_restriction->applied(),"Restriction cannot be changed since its border is still applied!");
(*m_clients)[id].m_restriction = restriction(merged_out_restrictions,merged_in_restrictions);
(*m_clients)[id].m_base_out_restrictions = out_restrictors;
(*m_clients)[id].m_base_in_restrictions = in_restrictors;
collect_garbage ();
}
void WebThings::add_stale(JSON *json)
{
// free unless its an object or array
if (!json->free_leaves()) {
NPIndex index = get_index(json);
// check if already in the stale set
for (unsigned int i = 0; i < stale_count; ++i) {
if (stale[i] == index)
return;
}
if (stale_count >= MAX_STALE)
collect_garbage();
if (stale_count < MAX_STALE)
stale[stale_count++] = index;
else
Serial.println(F("Exhausted room in stale set"));
}
}
bool
enqueue( queue *queue, void *data ) {
debug( "Enqueueing a data to a queue ( data = %p, queue = %p, length = %d ).", data, queue, queue != NULL ? queue->length : 0 );
assert( queue != NULL );
assert( queue->length >= 0 );
assert( data != NULL );
queue_element *new_tail = xmalloc( sizeof( queue_element ) );
new_tail->data = data;
new_tail->next = NULL;
queue->tail->next = new_tail;
queue->tail = new_tail;
__sync_add_and_fetch( &queue->length, 1 );
collect_garbage( queue );
debug( "Enqueue completed ( data = %p, queue = %p, length = %d ).", data, queue, queue->length );
return true;
}
Value * evaluate(Environment *env, Value *expr) {
EvaluationContext *ctx;
Value *temp, *result;
Value *operator;
Value *operand_val, *operand_cons;
Value *operands, *operands_end, *nil_value;
int num_operands;
/* Set up a new evaluation context and record our local variables, so that
* the garbage-collector can see any temporary values we use.
*/
ctx = push_new_evalctx(env, expr);
evalctx_register(&temp);
evalctx_register(&result);
evalctx_register(&operator);
evalctx_register(&operand_val);
evalctx_register(&operand_cons);
evalctx_register(&operands);
evalctx_register(&operands_end);
evalctx_register(&nil_value);
#ifdef VERBOSE_EVAL
printf("\nEvaluating expression: ");
print_value(stdout, expr);
printf("\n");
#endif
/* If this is a special form, evaluate it. Otherwise, this function will
* simply pass the input through to the result.
*/
result = eval_special_form(env, expr);
if (result != expr)
goto Done; /* It was a special form. */
/*
* If the input is an atom, we need to resolve it to a value, using the
* current environment.
*/
if (is_atom(expr)) {
/* Treat the atom as a name - resolve it to a value. */
result = resolve_binding(env, expr->string_val);
if (result == NULL) {
result = make_error("couldn't resolve name \"%s\" to a value!",
expr->string_val);
}
goto Done;
}
/*
* If the input isn't an atom and isn't a cons-pair, then assume it's a
* value that doesn't need evaluating, and just return it.
*/
if (!is_cons_pair(expr)) {
result = expr;
goto Done;
}
/*
* Evaluate operator into a lambda expression.
*/
temp = get_car(expr);
operator = evaluate(env, temp);
if (is_error(operator)) {
result = operator;
goto Done;
}
if (!is_lambda(operator)) {
result = make_error("operator is not a valid lambda expression");
goto Done;
}
#ifdef VERBOSE_EVAL
printf("Operator: ");
print_value(stdout, operator);
printf("\n");
#endif
/*
* Evaluate each operand into a value, and build a list up of the values.
*/
#ifdef VERBOSE_EVAL
printf("Starting evaluation of operands.\n");
#endif
num_operands = 0;
operands_end = NULL;
operands = nil_value = make_nil();
temp = get_cdr(expr);
while (is_cons_pair(temp)) {
Value *raw_operand;
num_operands++;
/* This is the raw unevaluated value. */
raw_operand = get_car(temp);
/* Evaluate the raw input into a value. */
operand_val = evaluate(env, raw_operand);
if (is_error(operand_val)) {
result = operand_val;
goto Done;
}
operand_cons = make_cons(operand_val, nil_value);
if (operands_end != NULL)
set_cdr(operands_end, operand_cons);
else
operands = operand_cons;
operands_end = operand_cons;
temp = get_cdr(temp);
}
/*
* Apply the operator to the operands, to generate a result.
*/
if (operator->lambda_val->native_impl) {
/* Native lambdas don't need an environment created for them. Rather,
* we just pass the list of arguments to the native function, and it
* processes the arguments as needed.
*/
result = operator->lambda_val->func(num_operands, operands);
}
else {
/* These don't need registered on the explicit stack. (I hope.) */
Environment *child_env;
Value *body_iter;
/* It's an interpreted lambda. Create a child environment, then
* populate it with values based on the lambda's argument-specification
* and the input operands.
*/
child_env = make_environment(operator->lambda_val->parent_env);
temp = bind_arguments(child_env, operator->lambda_val, operands);
if (is_error(temp)) {
result = temp;
goto Done;
}
/* Evaluate each expression in the lambda, using the child environment.
* The result of the last expression is the result of the lambda.
*/
body_iter = operator->lambda_val->body;
do {
result = evaluate(child_env, get_car(body_iter));
body_iter = get_cdr(body_iter);
}
while (!is_nil(body_iter));
}
Done:
#ifdef VERBOSE_EVAL
printf("Result: ");
print_value(stdout, result);
printf("\n\n");
#endif
/* Record the result and then perform garbage-collection. */
pop_evalctx(result);
collect_garbage();
return result;
}
/* ReadImage:
*/
static status_t ReadImage (lib7_state_t *lib7_state, inbuf_t *bp, lib7_val_t *chunkRef)
{
lib7_blast_hdr_t blastHdr;
lib7_val_t *externs;
heap_arena_hdr_t *arenaHdrs[NUM_CHUNK_KINDS], *arenaHdrsBuf;
int arenaHdrsSize, i;
gen_t *gen1 = lib7_state->lib7_heap->gen[0];
if ((HeapIO_ReadBlock(bp, &blastHdr, sizeof(blastHdr)) == FAILURE)
|| (blastHdr.numArenas > NUM_ARENAS)
|| (blastHdr.numBOKinds > NUM_BIGCHUNK_KINDS))
return FAILURE;
/* read the externals table */
externs = HeapIO_ReadExterns (bp);
/* read the arena headers. */
arenaHdrsSize = (blastHdr.numArenas + blastHdr.numBOKinds)
* sizeof(heap_arena_hdr_t);
arenaHdrsBuf = (heap_arena_hdr_t *) MALLOC (arenaHdrsSize);
if (HeapIO_ReadBlock (bp, arenaHdrsBuf, arenaHdrsSize) == FAILURE) {
FREE (arenaHdrsBuf);
return FAILURE;
}
for (i = 0; i < NUM_CHUNK_KINDS; i++)
arenaHdrs[i] = NULL;
for (i = 0; i < blastHdr.numArenas; i++) {
heap_arena_hdr_t *p = &(arenaHdrsBuf[i]);
arenaHdrs[p->chunkKind] = p;
}
/** DO BIG CHUNK HEADERS TOO **/
/* Check the heap to see if there is
* enough free space in the 1st generation:
*/
{
Addr_t allocSzB = lib7_state->lib7_heap->allocSzB;
bool_t needsGC = FALSE;
for (i = 0; i < NUM_ARENAS; i++) {
arena_t *ap = gen1->arena[i];
if ((arenaHdrs[i] != NULL) && ((! isACTIVE(ap))
|| (AVAIL_SPACE(ap) < arenaHdrs[i]->info.o.sizeB + allocSzB))) {
needsGC = TRUE;
ap->reqSizeB = arenaHdrs[i]->info.o.sizeB;
}
}
if (needsGC) {
if (bp->nbytes <= 0) {
collect_garbage (lib7_state, 1);
} else {
/* The garbage collection may cause the buffer to move, so: */
lib7_val_t buffer = PTR_CtoLib7(bp->base);
collect_garbage_with_extra_roots (lib7_state, 1, &buffer, NULL);
if (buffer != PTR_CtoLib7(bp->base)) {
/* The buffer moved, so adjust the buffer pointers: */
Byte_t *newBase = PTR_LIB7toC(Byte_t, buffer);
bp->buf = newBase + (bp->buf - bp->base);
bp->base = newBase;
}
}
}
}
/** Read the blasted chunks **/
{
Addr_t arenaBase[NUM_ARENAS];
for (i = 0; i < NUM_ARENAS; i++) {
if (arenaHdrs[i] != NULL) {
arena_t *ap = gen1->arena[i];
arenaBase[i] = (Addr_t)(ap->nextw);
HeapIO_ReadBlock (bp, (ap->nextw), arenaHdrs[i]->info.o.sizeB);
/*SayDebug ("[%2d] Read [%#x..%#x)\n", i+1, ap->nextw,*/
/*(Addr_t)(ap->nextw)+arenaHdrs[i]->info.o.sizeB);*/
}
}
/* adjust the pointers */
for (i = 0; i < NUM_ARENAS; i++) {
if (arenaHdrs[i] != NULL) {
arena_t *ap = gen1->arena[i];
if (i != STRING_INDEX) {
lib7_val_t *p, *stop;
p = ap->nextw;
stop = (lib7_val_t *)((Addr_t)p + arenaHdrs[i]->info.o.sizeB);
while (p < stop) {
lib7_val_t w = *p;
if (! isUNBOXED(w)) {
if (isEXTERNTAG(w)) {
w = externs[EXTERNID(w)];
}
else if (! isDESC(w)) {
/*SayDebug ("adjust (@%#x) %#x --> ", p, w);*/
w = PTR_CtoLib7(arenaBase[HIO_GET_ID(w)] + HIO_GET_OFFSET(w));
/*SayDebug ("%#x\n", w);*/
}
*p = w;
}
p++;
}
ap->nextw =
ap->sweep_nextw = stop;
}
else
ap->nextw = (lib7_val_t *)((Addr_t)(ap->nextw)
+ arenaHdrs[i]->info.o.sizeB);
}
} /* end of for */
/* adjust the root chunk pointer */
if (isEXTERNTAG(blastHdr.rootChunk))
*chunkRef = externs[EXTERNID(blastHdr.rootChunk)];
else
*chunkRef = PTR_CtoLib7(
arenaBase[HIO_GET_ID(blastHdr.rootChunk)]
+ HIO_GET_OFFSET(blastHdr.rootChunk));
/*SayDebug ("root = %#x, adjusted = %#x\n", blastHdr.rootChunk, *chunkRef);*/
}
FREE (arenaHdrsBuf);
FREE (externs);
return SUCCESS;
} /* end of ReadImage */
int main(int argc, char *argv[])
{
int result = 0;
ref_t val, answer, assoc, name;
FILE *input_fl = stdin, *output_fl = stdout;
clock_t start_time, end_time;
#define FREE_AND_RETURN(x) {result = x; goto free_and_return;}
if (parse_command_line(argc, argv, cmd_opt_decls) == -1)
{
printf("%s\n\n", get_error());
print_usage();
FREE_AND_RETURN(1);
}
if (help_flag)
{
print_usage();
FREE_AND_RETURN(0);
}
if (input_fname)
{
input_fl = fopen(input_fname, "r");
if (input_fl == 0)
{
printf("Could not open input file %s\n", input_fname);
FREE_AND_RETURN(1);
}
}
if (output_fname)
{
output_fl = fopen(output_fname, "w");
if (output_fl == 0)
{
printf("Could not open output file %s\n", output_fname);
FREE_AND_RETURN(1);
}
}
if (trace_file_fname)
{
trace_fl = fopen(trace_file_fname, "w");
if (trace_fl == 0)
{
printf("Could not open trace file %s\n", trace_file_fname);
FREE_AND_RETURN(1);
}
}
assoc = make_stack(nil());
register_gc_root(assoc);
stack_enter(assoc);
name = make_symbol("t", 0);
stack_let(assoc, name, name);
release_ref(&name);
register_core_lib(assoc);
REG_FN(exit, assoc);
REG_FN(trace, assoc);
REG_FN(profile, assoc);
REG_NAMED_FN("no-trace", slfe_no_trace, assoc);
REG_NAMED_FN("dump-stack", slfe_dump_stack, assoc);
if (trace_fl)
set_trace_file(trace_fl);
start_time = clock();
finished = 0;
while (! finished)
{
if (input_fl == stdin)
printf("> ");
val = read(input_fl);
answer = eval(val, assoc);
release_ref(&val);
if (!quiet_flag)
{
println(answer, output_fl);
fflush(output_fl);
}
release_ref(&answer);
collect_garbage();
}
stack_enter(nil());
unregister_gc_root(assoc);
release_ref(&assoc);
collect_garbage();
end_time = clock();
if (trace_fl)
fprintf(trace_fl, "Total time taken: %f seconds\n", (float)(end_time - start_time) / (float)CLOCKS_PER_SEC);
#undef FREE_AND_RETURN
free_and_return:
if (trace_fl && stats_flag)
fprintf(trace_fl, "Total symbol evals: %d; total stack switches: %d\n", symbol_eval_count, stack_switch_count);
if (input_fl != stdin) fclose(input_fl);
if (output_fl != stdout) fclose(output_fl);
if (trace_fl) fclose(trace_fl);
if (input_fname) X_FREE(input_fname);
if (output_fname) X_FREE(output_fname);
if (trace_file_fname) X_FREE(trace_file_fname);
return result;
}
static int eval_driver(const test_case_descriptor_t *tc)
{
int err_count = 0;
#if TEST_TRACE
printf("%s:%d eval %ls\n", tc->tcd_file, tc->tcd_lineno, tc->tcd_input);
#endif
static const char_t test_source[] =
L"(lambda (port loop env) \n"
L" (set! loop (lambda (form last) \n"
L" (if (eof-object? form) \n"
L" last \n"
L" (loop (read port) (eval form env))))) \n"
L" (loop (read port) #f))";
collect_garbage();
obj_t test_proc;
{
obj_t root_env = root_environment();
obj_t tsrc_str = make_string_from_C_str(test_source);
obj_t eval_sym = make_symbol_from_C_str(L"eval");
obj_t read_sym = make_symbol_from_C_str(L"read");
obj_t osip_sym = make_symbol_from_C_str(L"open-string-input-port");
obj_t renv_sym = make_symbol_from_C_str(L"root-environment");
/*
* (eval (read (open-string-input-port "..."))
* (root-environment))
*/
obj_t form1 = MAKE_LIST(eval_sym,
MAKE_LIST(read_sym,
MAKE_LIST(osip_sym, tsrc_str)),
MAKE_LIST(renv_sym));
test_proc = core_eval(form1, root_env);
// obj_t's are invalidated. core_eval may have GC'd.
}
obj_t port;
{
obj_t root_env = root_environment();
obj_t input_str = make_string_from_C_str(tc->tcd_input);
obj_t osip_sym = make_symbol_from_C_str(L"open-string-input-port");
port = core_eval(MAKE_LIST(osip_sym, input_str), root_env);
}
obj_t root_env = root_environment();
obj_t test_env = make_env(root_env);
obj_t test_args = MAKE_LIST(test_env, FALSE_OBJ, port);
obj_t cont = make_cont5(c_apply_proc,
EMPTY_LIST,
root_env,
test_proc,
EMPTY_LIST);
obj_t hname = make_symbol_from_C_str(L"test-handler");
obj_t handler = make_raw_procedure(c_test_handler, hname, root_env);
obj_t value = core_eval_cont(cont, test_args, handler);
/* Compare the value of the last expression. */
const size_t out_size = 100;
wchar_t actual[out_size + 1];
outstream_t *out = make_string_outstream(actual, out_size);
princ(value, out);
delete_outstream(out);
if (wcscmp(actual, tc->tcd_expected)) {
printf("%s:%d FAIL eval test\n", tc->tcd_file, tc->tcd_lineno);
printf(" input = %ls\n", tc->tcd_input);
printf(" actual = %ls\n", actual);
printf(" expected = %ls\n", tc->tcd_expected);
printf("\n");
err_count++;
}
return err_count;
}
int main(int argc, char** argv)
{
//freeing and coalescing tests
register void* base asm("ebp");
bool initTest = gc_init(100, base, false);
if(initTest == false)
{
printf("gc_init unsuccessful\n");
return -1;
}
void* test1 = gc_malloc(90);
void* test2 = gc_malloc(20);
if(test2 != NULL)
{
printf("test2 malloc fail unsuccessful\n");
return -1;
}
void* test3 = gc_malloc(10);
gc_free(test1);
void* test4 = gc_malloc(20);
void* test5 = gc_malloc(20);
//uncomment this to test garbage collector and pointer in heap
*((void**)test4) = test5;
test5 = gc_malloc(20);
print_heap();
printf("**************\n");
collect_garbage();
print_heap();
/*
Example Output:
(with line 33 commented)
Size: -1 In Use: true Address: 0x23a2010
Size: 20 In Use: true Address: 0x23a2010
Size: 20 In Use: true Address: 0x23a2024
Size: 20 In Use: true Address: 0x23a2038
Size: 30 In Use: false Address: 0x23a204c
Size: 10 In Use: true Address: 0x23a206a
**************
Size: -1 In Use: true Address: 0x23a2010
Size: 20 In Use: true Address: 0x23a2010
Size: 20 In Use: false Address: 0x23a2024 //This becomes false after collection
Size: 20 In Use: true Address: 0x23a2038
Size: 30 In Use: false Address: 0x23a204c
Size: 10 In Use: true Address: 0x23a206a
End of Program.
Example Output:
(with line 33 NOT commented)
*/
gc_free(test5);
gc_free(test3);
gc_free(test4);
gc_shutdown();
printf("End of Program.\n");
return 0;
}
