void tear_down_hook() {
gc_unregister_root(gc, (void **)&value);
gc_unregister_root(gc, (void **)&key1);
gc_unregister_root(gc, &hash);
/* Shutdown the GC */
gc_destroy(gc);
}
/* create a hashtable using the given function and
comparator */
void hash_create(gc_type *gc, hash_fn fn,
hash_cmp cmp, hashtable_type **ret) {
hash_internal_type *table = 0;
/* register the hashtable type with the gc */
if(!hashtable_type_def) {
hashtable_type_def = register_hashtable(gc);
key_value_type_def = register_key_value(gc);
}
gc_register_root(gc, (void**)&table);
gc_alloc_type(gc, 0, hashtable_type_def, (void **)&table);
table->gc = gc;
table->calc_hash = fn;
table->compare = cmp;
table->copy_on_write = false;
/* resize the hashtable */
hash_resize(table, HASH_SIZE);
table->key_value = key_value_type_def;
*ret = (hashtable_type *)table;
gc_unregister_root(gc, (void**)&table);
}
/* assemble a string on the stack into a proc */
void op_asm(vm_internal_type *vm) {
object_type *obj = 0;
object_type *closure =0;
env_type *env = 0;
uint8_t *code_ref = 0;
size_t written = 0;
gc_register_root(vm->gc, (void **)&obj);
gc_register_root(vm->gc, (void **)&closure);
gc_register_root(vm->gc, (void **)&code_ref);
gc_register_root(vm->gc, (void **)&env);
obj = vm_pop(vm);
if(!obj || obj->type != STRING) {
throw(vm, "Attempt to assemble non-string", 1, obj);
} else {
/* assemble the string */
written = asm_string(vm->gc, obj->value.string.bytes, &code_ref);
/* clone the current environment in a
closure */
clone_env(vm, (env_type **)&env, vm->env, false);
/* point to the entry point of our
assembled code_ref */
env->code_ref = code_ref;
env->ip = 0;
env->length = written;
closure = vm_alloc(vm, CLOSURE);
/* save the new closure onto our stack */
closure->value.closure = env;
vm_push(vm, closure);
}
gc_unregister_root(vm->gc, (void **)&env);
gc_unregister_root(vm->gc, (void **)&code_ref);
gc_unregister_root(vm->gc, (void **)&closure);
gc_unregister_root(vm->gc, (void **)&obj);
}
/* call a function off a given library */
void op_call_ext(vm_internal_type *vm) {
object_type *obj = 0;
object_type *lib = 0;
ext_call_type func_ptr = 0;
vm_int func = 0;
vm_int depth = 0;
gc_register_root(vm->gc, (void **)&obj);
gc_register_root(vm->gc, (void **)&lib);
obj = vm_pop(vm);
lib = vm_pop(vm);
depth = vm->depth; /* Save depth before call */
if(!obj || !lib || obj->type != FIXNUM || lib->type != LIBRARY) {
throw(vm, "Invalid arguments to call_ext", 2, obj, lib);
} else {
func = obj->value.integer;
if(func > lib->value.library.func_count) {
throw(vm, "Invalid function number", 2, obj, lib);
} else {
/* call the function */
func_ptr = ((binding_type *)lib->value.library.functions)[func].func;
(*func_ptr)(vm, vm->gc);
}
}
/* Make sure that something was returned */
if (vm->depth != depth) {
throw(vm, "Stack uneven after call_ext", 0 );
}
gc_unregister_root(vm->gc, (void **)&lib);
gc_unregister_root(vm->gc, (void **)&obj);
}
/* Save this label and its location in memory for latter
lookup */
void asm_label(gc_type *gc, buffer_type *buf,
hashtable_type *labels, char *str) {
vm_int *addr = 0;
char *key = 0;
gc_register_root(gc, (void**)&key);
gc_register_root(gc, (void**)&addr);
/* defensively copy the label name */
gc_alloc(gc, 0, strlen(str)+1, (void **)&key);
strcpy(key, str);
/* save location */
gc_alloc(gc, 0, sizeof(vm_int), (void **)&addr);
*addr = buffer_size(buf);
hash_set(labels, key, addr);
gc_unregister_root(gc, (void**)&key);
gc_unregister_root(gc, (void**)&addr);
}
void asm_jump(gc_type *gc, buffer_type *buf,
yyscan_t *scanner, jump_type **jump_list) {
static int init = 0;
static gc_type_def jump_def = 0;
jump_type *jump = 0;
char *label = 0;
/* TODO: This is a hack */
if(!init) {
init = 1;
jump_def = gc_register_type(gc, sizeof(jump_type));
gc_register_pointer(gc, jump_def, offsetof(jump_type, label));
gc_register_pointer(gc, jump_def, offsetof(jump_type, next));
}
gc_register_root(gc, (void **)&jump);
/* allocate a new jump */
gc_alloc_type(gc, 0, jump_def, (void **)&jump);
/* save location of jump addr field */
jump->addr = buffer_size(buf);
/* save the line number for this jump */
jump->lineno = yyget_lineno(scanner);
/* make sure we have a label */
if(yylex(scanner) != LABEL_TOKEN) {
assert(0);
}
/* save a copy of the label */
label = get_text(scanner);
gc_alloc(gc, 0, strlen(label)+1, (void **)&(jump->label));
strcpy(jump->label, label);
/* put this jump at the head of the
list */
jump->next = *jump_list;
*jump_list = jump;
gc_unregister_root(gc, (void **)&jump);
/* Make sure we have space to write target */
EMIT(buf, INT_64(0),8);
}
/* resize/allocagte hashtable array */
void hash_resize(hash_internal_type *table, size_t size) {
key_value_type **old_table = 0;
key_value_type *kv = 0;
size_t old_size = 0;
gc_register_root(table->gc, (void **)&old_table);
old_table = table->table;
old_size = table->size;
gc_alloc_pointer_array(table->gc,
0,
size,
(void **)&(table->table));
table->size = size;
table->entries = 0;
/* do we need to copy old entries into
the new table */
if(old_table) {
/* enumerate all old entries and add them to the
new table */
for(int i=0; i < old_size; i++) {
kv = old_table[i];
while(kv) {
/* save the previous value in the new
table */
hash_find(table, kv->key, CREATE)
->value = kv->value;
kv = kv->next;
}
}
}
gc_unregister_root(table->gc, (void **)&old_table);
}
/* Use our buffer library to slurp a file into a string */
size_t buffer_load_string(gc_type *gc, char *file, char **str) {
size_t count = 0;
buffer_type *buf = 0;
gc_register_root(gc, &buf);
buffer_create(gc, (void **)&buf);
/* Convert to a single string */
count = buffer_load(buf, file);
/* Make sure we could read the file */
if (count == -1 ) {
printf("Unable to load file: %s\n", file);
exit(-2);
}
gc_alloc(gc, 0, count+1, (void **)str);
buffer_read(buf, (uint8_t *)*str, count);
gc_unregister_root(gc, &buf);
return count;
}
/* Create an instance of the compiler */
void compiler_create(gc_type *gc, compiler_type **comp_void, char *compiler_home) {
compiler_core_type *compiler = 0;
static gc_type_def stream_gc_type = 0;
static gc_type_def node_literal_gc_type = 0;
static gc_type_def node_single_gc_type = 0;
static gc_type_def node_double_gc_type = 0;
static gc_type_def compiler_gc_type = 0;
// setup gc types
if (!compiler_gc_type) {
compiler_gc_type = register_compiler_type(gc);
stream_gc_type = register_stream_type(gc);
node_literal_gc_type = register_node_literal_type(gc);
node_single_gc_type = register_node_single_type(gc);
node_double_gc_type = register_node_double_type(gc);
}
gc_register_root(gc, (void **)&compiler);
/* create a compiler instance */
gc_alloc_type(gc, 0, compiler_gc_type, (void **)&compiler);
compiler->gc = gc;
compiler->label_index = 0;
/*compiler->preamble = "lib/preamble.asm";
compiler->postamble = "lib/postamble.asm";*/
strcpy(compiler->home, compiler_home);
/* setup gc types */
compiler->stream_gc_type = stream_gc_type;
compiler->node_types[STREAM_LITERAL] = node_literal_gc_type;
compiler->node_types[STREAM_SYMBOL] = node_literal_gc_type;
compiler->node_types[STREAM_STRING] = node_literal_gc_type;
compiler->node_types[STREAM_OP] = node_literal_gc_type;
compiler->node_types[STREAM_QUOTED] = node_single_gc_type;
compiler->node_types[STREAM_LOAD] = node_single_gc_type;
compiler->node_types[STREAM_ASM] = node_single_gc_type;
compiler->node_types[STREAM_ASM_STREAM] = node_single_gc_type;
compiler->node_types[STREAM_COND] = node_single_gc_type;
compiler->node_types[STREAM_AND] = node_single_gc_type;
compiler->node_types[STREAM_OR] = node_single_gc_type;
compiler->node_types[STREAM_RECORD_TYPE] = node_single_gc_type;
compiler->node_types[STREAM_BIND] = node_double_gc_type;
compiler->node_types[STREAM_STORE] = node_double_gc_type;
compiler->node_types[STREAM_LET_STAR] = node_double_gc_type;
compiler->node_types[STREAM_TWO_ARG] = node_double_gc_type;
compiler->node_types[STREAM_IF] = node_double_gc_type;
compiler->node_types[STREAM_MATH] = node_double_gc_type;
compiler->node_types[STREAM_LAMBDA] = node_double_gc_type;
compiler->node_types[STREAM_CALL] = node_double_gc_type;
*comp_void = compiler;
/* Add a stream route to the compiler object */
stream_create(compiler, &(compiler->stream));
/* Add the include stack array */
// TODO: Look at statically allocating this
compiler->include_depth = -1;
gc_alloc_pointer_array(gc, 0, MAX_INCLUDE_DEPTH, (void **)&(compiler->include_stack));
gc_unregister_root(gc, (void **)&compiler);
}
/* Entry point for the assembler. code_ref is assumed to be attached
to the gc. */
size_t asm_string(gc_type *gc, char *str, uint8_t **code_ref) {
yyscan_t scanner = 0;
op_type token = 0;
buffer_type *buf = 0;
hashtable_type *labels = 0;
jump_type *jump_list = 0;
size_t length = 0;
gc_register_root(gc, &buf);
gc_register_root(gc, &labels);
gc_register_root(gc, (void **)&jump_list);
/* create an output buffer */
buffer_create(gc, &buf);
hash_create_string(gc, &labels);
yylex_init(&scanner);
/* yyset_debug(1, scanner); */
/* set the scanners input */
yy_scan_string(str, scanner);
/* match until there is nothing left to match */
while((token = yylex(scanner)) != END_OF_FILE) {
/* Handle individual tokens */
switch((int)token) {
case OP_LIT_FIXNUM:
asm_lit_fixnum(buf, scanner);
break;
case OP_LIT_CHAR:
asm_lit_char(buf, scanner);
break;
case STRING_START_TOKEN:
EMIT(buf, OP_LIT_STRING, 1);
asm_lit_string(buf, scanner);
break;
case SYMBOL_START_TOKEN:
EMIT(buf, OP_LIT_SYMBOL, 1);
asm_lit_string(buf, scanner);
break;
case OP_JMP:
case OP_JNF:
case OP_CALL:
case OP_PROC:
case OP_CONTINUE:
EMIT(buf, token, 1); /* emit the jump operation */
asm_jump(gc, buf, scanner, &jump_list);
break;
case LABEL_TOKEN:
asm_label(gc, buf, labels, get_text(scanner));
break;
/* All otherwise not defined tokens are
their opcode */
default:
EMIT(buf, token, 1);
break;
}
}
yylex_destroy(scanner);
/* build a code_ref */
length = buffer_size(buf);
/* *code_ref = gc_alloc(gc, 0, length); */
gc_alloc(gc, 0, length, (void **)code_ref);
length = buffer_read(buf, *code_ref, length);
/* replace jump address fields */
rewrite_jumps(*code_ref, jump_list, labels);
gc_unregister_root(gc, &buf);
gc_unregister_root(gc, &labels);
gc_unregister_root(gc, (void **)&jump_list);
return length;
}
/* do a dlopen on a dll */
void op_import(vm_internal_type *vm) {
object_type *obj = 0;
object_type *obj2 = 0;
object_type *lib = 0;
object_type *binding_alist = 0;
char *path = 0;
vm_int length = 0;
void *handle = 0;
binding_type **export_list = 0;
char *symbol = 0;
vm_int func_count = 0;
char *msg = 0;
gc_register_root(vm->gc, (void **)&obj);
gc_register_root(vm->gc, (void **)&obj2);
gc_register_root(vm->gc, (void **)&lib);
gc_register_root(vm->gc, (void **)&binding_alist);
gc_register_root(vm->gc, (void **)&path);
obj = vm_pop(vm);
if(!obj || obj->type != STRING) {
throw(vm, "Attempt to import with non-string filename", 1, obj);
} else {
/* allocate a string long enough to include the either .so or .dylib */
length = obj->value.string.length + LIB_EXT_LEN + 1;
gc_alloc(vm->gc, 0, length, (void **)&path);
strncpy(path, obj->value.string.bytes, length);
strncat(path, LIB_EXT, length);
/* if we have already imported this library,
return the existing library object */
if(hash_get(vm->import_table, path, (void**)&lib)) {
vm_push(vm, lib);
} else {
/* check if the library has been loaded */
handle = dlopen(path, RTLD_NOW | RTLD_LOCAL | RTLD_NOLOAD);
/* load the library if it has not been loaded */
if(!handle) {
/* handle = dlopen(obj->value.string.bytes, RTLD_NOW | RTLD_LOCAL | RTLD_DEEPBIND); */
/* RTLD_DEEPBIND is not defined on osx ... */
handle = dlopen(path, RTLD_NOW | RTLD_LOCAL);
}
/* check to make sure we did not run into an error */
if(!handle) {
throw(vm, dlerror(), 1, obj);
} else {
lib = vm_alloc(vm, LIBRARY);
dlerror(); /* Clear error states */
export_list = (binding_type **)dlsym(handle, "export_list");
if((msg = dlerror())) {
throw(vm, msg, 1, obj);
} else {
func_count = 0;
while(((binding_type *)export_list)[func_count].func) {
func_count++;
}
lib->value.library.handle = handle;
lib->value.library.functions = export_list;
lib->value.library.func_count = func_count;
/* save this library off into the import table. */
hash_set(vm->import_table, path, lib);
vm_push(vm, lib);
}
}
}
/* if lib is still 0, we couldn't load it. */
if (lib != 0) {
/* setup a binding alist so we can bind the exported
* symbols to function call values
*/
binding_alist = vm->empty;
export_list = lib->value.library.functions;
func_count = 0;
/* count the number of functions */
while(((binding_type *)export_list)[func_count].func) {
symbol = ((binding_type *)export_list)[func_count].symbol;
/* create string object */
obj = vm_make_string(vm,
symbol,
strlen(symbol));
/* make our string into a symbol */
make_symbol(vm, &obj);
/* convert the func_counter into a number */
obj2 = vm_alloc(vm, FIXNUM);
obj2->value.integer = func_count;
cons(vm, obj, obj2, &(vm->reg1));
cons(vm, vm->reg1, binding_alist, &(vm->reg2));
binding_alist = vm->reg2;
/* increment function count */
func_count++;
}
vm_push(vm, binding_alist);
}
}
gc_unregister_root(vm->gc, (void **)&path);
gc_unregister_root(vm->gc, (void **)&binding_alist);
gc_unregister_root(vm->gc, (void **)&lib);
gc_unregister_root(vm->gc, (void **)&obj2);
gc_unregister_root(vm->gc, (void **)&obj);
}
/* locate or create a key_value_object the given key */
key_value_type *hash_find(hash_internal_type *table,
void *key, hash_action_type action) {
hash_type hash = (*table->calc_hash)(key);
hash_type index = hash % table->size; /* calculate the search table index */
key_value_type *kv = 0;
key_value_type *prev_kv = 0;
/* Check for "write" operations and a COW hash */
if (table->copy_on_write && (action == CREATE || action == DELETE)) {
/* resize implicitly copies everything */
hash_resize(table, table->size);
table->copy_on_write = false;
}
/* is there anything at the given index? */
if((kv = table->table[index])) {
/* search through the list of key value pairs */
while(kv) {
if((*table->compare)(key, kv->key) == EQ) {
/* do the delete if needed */
if(action == DELETE) {
/* Do we have a chain? */
if(prev_kv) {
/* Remove node from chain */
prev_kv->next = kv->next;
} else {
/* This node is either the head of a chain
or there is no chain. */
table->table[index] = kv->next;
}
}
return kv;
}
prev_kv = kv;
kv = kv->next;
}
}
/* we did not find the key, should we create it? */
if(action == CREATE) {
gc_register_root(table->gc, (void**)&kv);
gc_alloc_type(table->gc, 0, table->key_value, (void **)&kv);
kv->key = key;
/* attach kv to table */
kv->next = table->table[index];
table->table[index] = kv;
table->entries++;
gc_unregister_root(table->gc, (void**)&kv);
return kv;
}
return 0;
}
