void eval(BOOLEAN do_gc)
{
static unsigned int count = 0;
OBJECT_PTR exp = car(reg_next_expression);
OBJECT_PTR opcode = car(exp);
pin_globals();
if(do_gc)
{
count++;
if(count == GC_FREQUENCY)
{
gc(false, true);
count = 0;
}
}
if(opcode == APPLY && profiling_in_progress)
{
last_operator = reg_accumulator;
if(prev_operator != NIL)
{
OBJECT_PTR operator_to_be_used;
hashtable_entry_t *e;
unsigned int count;
unsigned int mem_alloc;
double elapsed_wall_time;
double elapsed_cpu_time;
double temp1 = get_wall_time();
clock_t temp2 = clock();
unsigned int temp3 = memory_allocated();
profiling_datum_t *pd = (profiling_datum_t *)malloc(sizeof(profiling_datum_t));
if(IS_SYMBOL_OBJECT(prev_operator))
operator_to_be_used = prev_operator;
else
{
OBJECT_PTR res = get_symbol_from_value(prev_operator, reg_current_env);
if(car(res) != NIL)
operator_to_be_used = cdr(res);
else
operator_to_be_used = cons(LAMBDA,
cons(get_params_object(prev_operator),
cons(car(get_source_object(prev_operator)), NIL)));
}
e = hashtable_get(profiling_tab, (void *)operator_to_be_used);
if(e)
{
profiling_datum_t *pd = (profiling_datum_t *)e->value;
count = pd->count + 1;
elapsed_wall_time = pd->elapsed_wall_time + temp1 - wall_time_var;
elapsed_cpu_time = pd->elapsed_cpu_time + (temp2 - cpu_time_var) * 1.0 / CLOCKS_PER_SEC;
mem_alloc = pd->mem_allocated + temp3 - mem_alloc_var;
hashtable_remove(profiling_tab, (void *)operator_to_be_used);
free(pd);
}
else
{
count = 1;
elapsed_wall_time = temp1 - wall_time_var;
elapsed_cpu_time = (temp2 - cpu_time_var) * 1.0 / CLOCKS_PER_SEC;
mem_alloc = temp3 - mem_alloc_var;
}
pd->count = count;
pd->elapsed_wall_time = elapsed_wall_time;
pd->elapsed_cpu_time = elapsed_cpu_time;
pd->mem_allocated = mem_alloc;
hashtable_put(profiling_tab, (void *)operator_to_be_used, (void *)pd);
}
wall_time_var = get_wall_time();
cpu_time_var = clock();
mem_alloc_var = memory_allocated();
prev_operator = reg_accumulator;
}
if(opcode == HALT)
{
halt_op();
}
else if(opcode == REFER)
{
if(refer(CADR(exp)))
return;
reg_next_expression = CADDR(exp);
}
else if(opcode == CONSTANT)
{
if(constant(CADR(exp)))
return;
reg_next_expression = CADDR(exp);
}
else if(opcode == CLOSE)
{
if(closure(exp))
return;
reg_next_expression = fifth(exp);
}
else if(opcode == MACRO)
{
if(macro(exp))
return;
reg_next_expression = CADDDDR(exp);
}
else if(opcode == TEST)
{
if(reg_accumulator != NIL)
reg_next_expression = CADR(exp);
else
reg_next_expression = CADDR(exp);
}
//Not using this WHILE; reverting
//to macro definition, as this
//version doesn't handle (BREAK)
else if(opcode == WHILE)
{
OBJECT_PTR cond = CADR(exp);
OBJECT_PTR body = CADDR(exp);
OBJECT_PTR ret = NIL;
while(1)
{
OBJECT_PTR temp = reg_current_stack;
reg_next_expression = cond;
while(car(reg_next_expression) != NIL)
{
eval(false);
if(in_error)
return;
}
if(reg_accumulator == NIL)
break;
reg_next_expression = body;
while(car(reg_next_expression) != NIL)
{
eval(false);
if(in_error)
return;
}
//to handle premature exits
//via RETURN-FROM
if(reg_current_stack != temp)
return;
ret = reg_accumulator;
}
reg_accumulator = ret;
reg_next_expression = CADDDR(exp);
}
else if(opcode == ASSIGN)
{
if(assign(CADR(exp)))
return;
reg_next_expression = CADDR(exp);
}
else if(opcode == DEFINE)
{
if(define(CADR(exp)))
return;
reg_next_expression = CADDR(exp);
}
else if(opcode == CONTI)
{
if(conti())
return;
reg_next_expression = CADR(exp);
}
else if(opcode == NUATE) //this never gets called
{
reg_current_stack = CADR(exp);
reg_accumulator = CADDR(exp);
reg_current_value_rib = NIL;
reg_next_expression = cons(CONS_RETURN_NIL, cdr(reg_next_expression));
}
else if(opcode == FRAME)
{
if(frame(exp))
return;
reg_next_expression = CADDR(exp);
}
else if(opcode == ARGUMENT)
{
if(argument())
return;
reg_next_expression = CADR(exp);
}
else if(opcode == APPLY)
{
apply_compiled();
}
else if(opcode == RETURN)
{
return_op();
}
}
void gc_orig(BOOLEAN force, BOOLEAN clear_black)
{
static unsigned long count = 0;
if(!can_do_gc)
return;
//no new objects were created since the
//last GC cycle, so nothing to do.
if(is_set_empty(WHITE))
return;
//do GC every GC_FREQUENCYth time called
if((count % GC_FREQUENCY) != 0)
return;
//printf("Entering GC cycle... ");
unsigned int dealloc_words = memory_deallocated();
//assert(is_set_empty(GREY));
build_grey_set();
assert(!is_set_empty(GREY));
while(!is_set_empty(GREY))
{
OBJECT_PTR obj = get_an_object_from_grey();
assert(is_dynamic_memory_object(obj));
//FUNCTION2 and MACRO2 objects are handled
//by handling their undelying CONS objects
if(!IS_FUNCTION2_OBJECT(obj) && !IS_MACRO2_OBJECT(obj))
insert_node(BLACK, obj);
remove_node(GREY, obj);
if(IS_CONS_OBJECT(obj))
{
move_from_white_to_grey(car(obj));
move_from_white_to_grey(cdr(obj));
}
else if(IS_CLOSURE_OBJECT(obj) || IS_MACRO_OBJECT(obj))
{
move_from_white_to_grey(get_env_list(obj));
move_from_white_to_grey(get_params_object(obj));
move_from_white_to_grey(get_body_object(obj));
move_from_white_to_grey(get_source_object(obj));
}
else if(IS_ARRAY_OBJECT(obj))
{
uintptr_t ptr = extract_ptr(obj);
//OBJECT_PTR length_obj = get_heap(ptr, 0);
//move_from_white_to_grey(length_obj);
//int len = get_int_value(length_obj);
int len = *((OBJECT_PTR *)ptr);
int i;
for(i=1; i<=len; i++)
move_from_white_to_grey(get_heap(ptr, i));
}
else if(IS_CONTINUATION_OBJECT(obj))
move_from_white_to_grey(get_heap(extract_ptr(obj), 0));
else if(IS_FUNCTION2_OBJECT(obj) || IS_MACRO2_OBJECT(obj))
{
OBJECT_PTR cons_equiv = cons_equivalent(obj);
//move_from_white_to_grey(car(cons_equiv));
//move_from_white_to_grey(cdr(cons_equiv));
move_from_white_to_grey(cons_equiv);
}
} //end of while(!is_set_empty(GREY))
free_white_set_objects();
assert(is_set_empty(GREY));
assert(is_set_empty(WHITE));
assert(!is_set_empty(BLACK));
/* if(clear_black) */
/* recreate_black(); */
/* if(clear_black) */
/* assert(is_set_empty(BLACK)); */
//printf("%d words deallocated in current GC cycle\n", memory_deallocated() - dealloc_words);
}