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; }