/* * Transform * * (case-lambda * ((<form1> <body1>) * (<form2> <body2>) * ...) * * to * * (lambda args * (cond * (((if (variadic? <form1>) >= =) (length args) <form1-min-args>) * (apply (lambda (<form1>) <body1>) args)) * ...)) */ cons_t* proc_case_lambda(cons_t* p, environment_t* e) { cons_t *cond_cases = list(); cons_t *cases = p; for ( cons_t* c = cases; !nullp(c); c = cdr(c) ) { cons_t *formals = caar(c); cons_t *body = cdar(c); // ((if (variadic? <form1>) >= =) argc <form1-min-args>) cons_t* cond_if = cons(symbol(variadicp(formals)? ">=" : "="), cons(cons(symbol("length"), cons(symbol("args"))), cons(integer(min_args(formals))))); // (apply (lambda (<form1>) <body1>) args) cons_t *cond_then = cons(symbol("apply"), cons(cons(symbol("lambda"), cons(formals, body)), cons(symbol("args")))); cond_cases = append(cond_cases, list(list(cond_if, cond_then))); } cond_cases = splice(cons(symbol("cond")), cond_cases); return make_closure(symbol("args"), cons(cond_cases), e); }
int main(void) { (void)box_float; (void)box_double; (void)box_string; /*Allocate an environment * The environment size depends on how many nested functions there are ? */ svalue_t **env = calloc(sizeof (svalue_t *), 2); /* Get the final closure */ svalue_t *closure1 = make_closure(make_doubleadder, env); /* Invoke the closure that the closure returns */ svalue_t *c1 = invoke1(closure1, box_int(23)); svalue_t *c2 = invoke1(c1, box_int(5)); svalue_t *result = invoke1(c2, box_int(334)); /* The final result */ printf("print 23 + 5 + 334 == %d\n", result->value.integer); svalue_t *a = box_int(123); svalue_t *b = box_int(455); svalue_t *improper = box_pair(a, b); improper->value.pair.right = improper; /* woo cyclic pair */ printf("(%d, %d)\n", improper->value.pair.left->value.integer, improper->value.pair.right->value.pair.left->value.integer); return 0; }
sexp call_lambda_as_ffi_closure(sexp lambda,sexp arg){ void **closure; closure=make_closure(lambda,env_sexp(cur_env_ptr),1); if(!closure){ return error_sexp("error constructing ffi_closure"); } sexp(*f)(sexp)=(sexp(*)(sexp))(closure[0]); sexp retval=f(arg); return retval; }
static void cljc_init (void) { GC_INIT (); PTABLE_NAME (cljc_DOT_core_SLASH_Nil) = alloc_ptable (TYPE_Nil); PTABLE_NAME (cljc_DOT_core_SLASH_Integer) = alloc_ptable (TYPE_Integer); PTABLE_NAME (cljc_DOT_core_SLASH_Boolean) = alloc_ptable (TYPE_Boolean); PTABLE_NAME (cljc_DOT_core_SLASH_Array) = alloc_ptable (TYPE_Array); PTABLE_NAME (cljc_DOT_core_SLASH_Character) = alloc_ptable (TYPE_Character); PTABLE_NAME (cljc_DOT_core_SLASH_String) = alloc_ptable (TYPE_String); value_nil = alloc_value (PTABLE_NAME (cljc_DOT_core_SLASH_Nil), sizeof (value_t)); value_true = alloc_value (PTABLE_NAME (cljc_DOT_core_SLASH_Boolean), sizeof (value_t)); value_false = alloc_value (PTABLE_NAME (cljc_DOT_core_SLASH_Boolean), sizeof (value_t)); VAR_NAME (cljc_DOT_core_SLASH_print) = make_closure (cljc_core_print, NULL); VAR_NAME (cljc_DOT_core_SLASH_apply) = make_closure (cljc_core_apply, NULL); }
void execute(Chunk *chunk) { Closure *closure = make_closure(chunk); Frame *frame = make_frame(NULL, closure); VM *vm = make_vm(frame, 0); execute_function(vm); gc(vm); free(vm); // TODO - free last closure [?] // Other closrues should be already taken care of // by the last gc sweep, but this one existed outside // of the heap. }
void funcXXX(struct vm *vm){ ENTER_CLOSURE(1,"funcXXX"); vm->value = make_number(3); PUSH(vm->value); value = SHALLOW_ARGUMENT_REF(0); vm->func = vm->value; vm->value = make_vector(1); CLOSURE_CALL() vector_set(vm->value,0,POP()) PUSH(vm->value); vm->value = make_closure(funcXXX,vm->env); value = SHALLOW_ARGUMENT_SET(0); vm->func = vm->value; vm->value = make_vector(1); CLOSURE_CALL() vector_set(vm->value,0,POP()) EXIT_CLOSURE(); }
static struct frame* frame_push(struct jq_state* jq, struct closure callee, uint16_t* argdef, int nargs) { stack_ptr new_frame_idx = stack_push_block(&jq->stk, jq->curr_frame, frame_size(callee.bc)); struct frame* new_frame = stack_block(&jq->stk, new_frame_idx); new_frame->bc = callee.bc; new_frame->env = callee.env; assert(nargs == new_frame->bc->nclosures); union frame_entry* entries = new_frame->entries; int i; for (i=0; i<nargs; i++) { entries->closure = make_closure(jq, argdef + i * 2); entries++; } for (i=0; i<callee.bc->nlocals; i++) { entries->localvar = jv_invalid(); entries++; } jq->curr_frame = new_frame_idx; return new_frame; }
static svalue_t* make_doubleadder(svalue_t **x, svalue_t **env) { env[0] = *x; return make_closure(make_doubleadder_inner, env); }
static inline svalue_t* make_doubleadder_inner(svalue_t **y, svalue_t **env) { env[1] = *y; return make_closure(make_doubleadder_inner_inner, env); }
} void funcXXX(struct vm *vm){ ENTER_CLOSURE(1,"funcXXX"); vm->value = make_number(6); value = SHALLOW_ARGUMENT_SET(1); value = SHALLOW_ARGUMENT_REF(0); PUSH(vm->value); value = SHALLOW_ARGUMENT_REF(1); PUSH(vm->value); vm->value = cons(POP(),POP()) EXIT_CLOSURE(); } void funcXXX(struct vm *vm){ ENTER_CLOSURE(1,"funcXXX"); vm->value = make_number(6); value = SHALLOW_ARGUMENT_SET(1); value = SHALLOW_ARGUMENT_REF(0); PUSH(vm->value); value = SHALLOW_ARGUMENT_REF(1); PUSH(vm->value); vm->value = cons(POP(),POP()) EXIT_CLOSURE(); } //code vm->value = make_closure(funcXXX,vm->env); vm->func = vm->value; vm->value = make_vector(0); CLOSURE_CALL()
jv jq_next(jq_state *jq) { jv cfunc_input[MAX_CFUNCTION_ARGS]; jv_nomem_handler(jq->nomem_handler, jq->nomem_handler_data); uint16_t* pc = stack_restore(jq); assert(pc); int backtracking = !jq->initial_execution; jq->initial_execution = 0; while (1) { uint16_t opcode = *pc; if (jq->debug_trace_enabled) { dump_operation(frame_current(jq)->bc, pc); printf("\t"); const struct opcode_description* opdesc = opcode_describe(opcode); stack_ptr param = 0; if (!backtracking) { int stack_in = opdesc->stack_in; if (stack_in == -1) stack_in = pc[1]; int i; for (i=0; i<stack_in; i++) { if (i == 0) { param = jq->stk_top; } else { printf(" | "); param = *stack_block_next(&jq->stk, param); } if (!param) break; jv_dump(jv_copy(*(jv*)stack_block(&jq->stk, param)), 0); //printf("<%d>", jv_get_refcnt(param->val)); //printf(" -- "); //jv_dump(jv_copy(jq->path), 0); } } else { printf("\t<backtracking>"); } printf("\n"); } if (backtracking) { opcode = ON_BACKTRACK(opcode); backtracking = 0; } pc++; switch (opcode) { default: assert(0 && "invalid instruction"); case LOADK: { jv v = jv_array_get(jv_copy(frame_current(jq)->bc->constants), *pc++); assert(jv_is_valid(v)); jv_free(stack_pop(jq)); stack_push(jq, v); break; } case DUP: { jv v = stack_pop(jq); stack_push(jq, jv_copy(v)); stack_push(jq, v); break; } case DUP2: { jv keep = stack_pop(jq); jv v = stack_pop(jq); stack_push(jq, jv_copy(v)); stack_push(jq, keep); stack_push(jq, v); break; } case SUBEXP_BEGIN: { jv v = stack_pop(jq); stack_push(jq, jv_copy(v)); stack_push(jq, v); jq->subexp_nest++; break; } case SUBEXP_END: { assert(jq->subexp_nest > 0); jq->subexp_nest--; jv a = stack_pop(jq); jv b = stack_pop(jq); stack_push(jq, a); stack_push(jq, b); break; } case POP: { jv_free(stack_pop(jq)); break; } case APPEND: { jv v = stack_pop(jq); uint16_t level = *pc++; uint16_t vidx = *pc++; jv* var = frame_local_var(jq, vidx, level); assert(jv_get_kind(*var) == JV_KIND_ARRAY); *var = jv_array_append(*var, v); break; } case INSERT: { jv stktop = stack_pop(jq); jv v = stack_pop(jq); jv k = stack_pop(jq); jv objv = stack_pop(jq); assert(jv_get_kind(objv) == JV_KIND_OBJECT); if (jv_get_kind(k) == JV_KIND_STRING) { stack_push(jq, jv_object_set(objv, k, v)); stack_push(jq, stktop); } else { print_error(jq, jv_invalid_with_msg(jv_string_fmt("Cannot use %s as object key", jv_kind_name(jv_get_kind(k))))); jv_free(stktop); jv_free(v); jv_free(k); jv_free(objv); goto do_backtrack; } break; } case ON_BACKTRACK(RANGE): case RANGE: { uint16_t level = *pc++; uint16_t v = *pc++; jv* var = frame_local_var(jq, v, level); jv max = stack_pop(jq); if (jv_get_kind(*var) != JV_KIND_NUMBER || jv_get_kind(max) != JV_KIND_NUMBER) { print_error(jq, jv_invalid_with_msg(jv_string_fmt("Range bounds must be numeric"))); jv_free(max); goto do_backtrack; } else if (jv_number_value(jv_copy(*var)) >= jv_number_value(jv_copy(max))) { /* finished iterating */ goto do_backtrack; } else { jv curr = jv_copy(*var); *var = jv_number(jv_number_value(*var) + 1); struct stack_pos spos = stack_get_pos(jq); stack_push(jq, jv_copy(max)); stack_save(jq, pc - 3, spos); stack_push(jq, curr); } break; } // FIXME: loadv/storev may do too much copying/freeing case LOADV: { uint16_t level = *pc++; uint16_t v = *pc++; jv* var = frame_local_var(jq, v, level); if (jq->debug_trace_enabled) { printf("V%d = ", v); jv_dump(jv_copy(*var), 0); printf("\n"); } jv_free(stack_pop(jq)); stack_push(jq, jv_copy(*var)); break; } // Does a load but replaces the variable with null case LOADVN: { uint16_t level = *pc++; uint16_t v = *pc++; jv* var = frame_local_var(jq, v, level); if (jq->debug_trace_enabled) { printf("V%d = ", v); jv_dump(jv_copy(*var), 0); printf("\n"); } jv_free(stack_pop(jq)); stack_push(jq, *var); *var = jv_null(); break; } case STOREV: { uint16_t level = *pc++; uint16_t v = *pc++; jv* var = frame_local_var(jq, v, level); jv val = stack_pop(jq); if (jq->debug_trace_enabled) { printf("V%d = ", v); jv_dump(jv_copy(val), 0); printf("\n"); } jv_free(*var); *var = val; break; } case PATH_BEGIN: { jv v = stack_pop(jq); stack_push(jq, jq->path); stack_save(jq, pc - 1, stack_get_pos(jq)); stack_push(jq, jv_number(jq->subexp_nest)); stack_push(jq, v); jq->path = jv_array(); jq->subexp_nest = 0; break; } case PATH_END: { jv v = stack_pop(jq); jv_free(v); // discard value, only keep path int old_subexp_nest = (int)jv_number_value(stack_pop(jq)); jv path = jq->path; jq->path = stack_pop(jq); struct stack_pos spos = stack_get_pos(jq); stack_push(jq, jv_copy(path)); stack_save(jq, pc - 1, spos); stack_push(jq, path); jq->subexp_nest = old_subexp_nest; break; } case ON_BACKTRACK(PATH_BEGIN): case ON_BACKTRACK(PATH_END): { jv_free(jq->path); jq->path = stack_pop(jq); goto do_backtrack; } case INDEX: case INDEX_OPT: { jv t = stack_pop(jq); jv k = stack_pop(jq); path_append(jq, jv_copy(k)); jv v = jv_get(t, k); if (jv_is_valid(v)) { stack_push(jq, v); } else { if (opcode == INDEX) print_error(jq, v); else jv_free(v); goto do_backtrack; } break; } case JUMP: { uint16_t offset = *pc++; pc += offset; break; } case JUMP_F: { uint16_t offset = *pc++; jv t = stack_pop(jq); jv_kind kind = jv_get_kind(t); if (kind == JV_KIND_FALSE || kind == JV_KIND_NULL) { pc += offset; } stack_push(jq, t); // FIXME do this better break; } case EACH: case EACH_OPT: stack_push(jq, jv_number(-1)); // fallthrough case ON_BACKTRACK(EACH): case ON_BACKTRACK(EACH_OPT): { int idx = jv_number_value(stack_pop(jq)); jv container = stack_pop(jq); int keep_going, is_last = 0; jv key, value; if (jv_get_kind(container) == JV_KIND_ARRAY) { if (opcode == EACH || opcode == EACH_OPT) idx = 0; else idx = idx + 1; int len = jv_array_length(jv_copy(container)); keep_going = idx < len; is_last = idx == len - 1; if (keep_going) { key = jv_number(idx); value = jv_array_get(jv_copy(container), idx); } } else if (jv_get_kind(container) == JV_KIND_OBJECT) { if (opcode == EACH || opcode == EACH_OPT) idx = jv_object_iter(container); else idx = jv_object_iter_next(container, idx); keep_going = jv_object_iter_valid(container, idx); if (keep_going) { key = jv_object_iter_key(container, idx); value = jv_object_iter_value(container, idx); } } else { assert(opcode == EACH || opcode == EACH_OPT); if (opcode == EACH) { print_error(jq, jv_invalid_with_msg(jv_string_fmt("Cannot iterate over %s", jv_kind_name(jv_get_kind(container))))); } keep_going = 0; } if (!keep_going) { jv_free(container); goto do_backtrack; } else if (is_last) { // we don't need to make a backtrack point jv_free(container); path_append(jq, key); stack_push(jq, value); } else { struct stack_pos spos = stack_get_pos(jq); stack_push(jq, container); stack_push(jq, jv_number(idx)); stack_save(jq, pc - 1, spos); path_append(jq, key); stack_push(jq, value); } break; } do_backtrack: case BACKTRACK: { pc = stack_restore(jq); if (!pc) { return jv_invalid(); } backtracking = 1; break; } case FORK: { stack_save(jq, pc - 1, stack_get_pos(jq)); pc++; // skip offset this time break; } case ON_BACKTRACK(FORK): { uint16_t offset = *pc++; pc += offset; break; } case CALL_BUILTIN: { int nargs = *pc++; jv top = stack_pop(jq); jv* in = cfunc_input; int i; in[0] = top; for (i = 1; i < nargs; i++) { in[i] = stack_pop(jq); } struct cfunction* function = &frame_current(jq)->bc->globals->cfunctions[*pc++]; typedef jv (*func_1)(jv); typedef jv (*func_2)(jv,jv); typedef jv (*func_3)(jv,jv,jv); typedef jv (*func_4)(jv,jv,jv,jv); typedef jv (*func_5)(jv,jv,jv,jv,jv); switch (function->nargs) { case 1: top = ((func_1)function->fptr)(in[0]); break; case 2: top = ((func_2)function->fptr)(in[0], in[1]); break; case 3: top = ((func_3)function->fptr)(in[0], in[1], in[2]); break; case 4: top = ((func_4)function->fptr)(in[0], in[1], in[2], in[3]); break; case 5: top = ((func_5)function->fptr)(in[0], in[1], in[2], in[3], in[4]); break; default: return jv_invalid_with_msg(jv_string("Function takes too many arguments")); } if (jv_is_valid(top)) { stack_push(jq, top); } else { print_error(jq, top); goto do_backtrack; } break; } case CALL_JQ: { jv input = stack_pop(jq); uint16_t nclosures = *pc++; uint16_t* retaddr = pc + 2 + nclosures*2; struct frame* new_frame = frame_push(jq, make_closure(jq, pc), pc + 2, nclosures); new_frame->retdata = jq->stk_top; new_frame->retaddr = retaddr; pc = new_frame->bc->code; stack_push(jq, input); break; } case RET: { jv value = stack_pop(jq); assert(jq->stk_top == frame_current(jq)->retdata); uint16_t* retaddr = frame_current(jq)->retaddr; if (retaddr) { // function return pc = retaddr; frame_pop(jq); } else { // top-level return, yielding value struct stack_pos spos = stack_get_pos(jq); stack_push(jq, jv_null()); stack_save(jq, pc - 1, spos); return value; } stack_push(jq, value); break; } case ON_BACKTRACK(RET): { // resumed after top-level return goto do_backtrack; } } } }
void execute_function(VM *vm) { restart: { Frame *frame = vm->current; Closure *closure = frame->closure; Chunk *chunk = closure->chunk; StackObject *registers = frame->registers; while (frame->pc < chunk->numinstructions) { int instruction = chunk->instructions[frame->pc]; OpCode o = GET_O(instruction); int a = GET_A(instruction); int b = GET_B(instruction); int c = GET_C(instruction); switch (o) { case OP_MOVE: { if (b < 256) { copy_object(®isters[a], ®isters[b]); } else { copy_constant(vm, ®isters[a], chunk->constants[b - 256]); } } break; case OP_GETUPVAR: { Upval *upval = closure->upvals[b]; if (!upval->open) { // upval is closed copy_object(®isters[a], upval->data.o); } else { // still on stack copy_object(®isters[a], &upval->data.ref.frame->registers[upval->data.ref.slot]); } } break; case OP_SETUPVAR: { Upval *upval = closure->upvals[b]; if (!upval->open) { // upval is closed copy_object(upval->data.o, ®isters[a]); } else { // still on stack copy_object(&upval->data.ref.frame->registers[upval->data.ref.slot], ®isters[a]); } } break; case OP_ADD: { // TODO - make string coercion better // TODO - make string type with special operators if (IS_STR(b) || IS_STR(c)) { char *arg1 = TO_STR(b); char *arg2 = TO_STR(c); char *arg3 = malloc((strlen(arg1) + strlen(arg2) + 1) + sizeof *arg3); strcpy(arg3, arg1); strcat(arg3, arg2); registers[a].value.o = make_string_ref(vm, arg3); registers[a].type = OBJECT_REFERENCE; // put this after free(arg1); free(arg2); } else { if (!(IS_INT(b) || IS_REAL(b)) || !(IS_INT(c) || IS_REAL(c))) { fatal("Cannot add types."); } if (IS_INT(b) && IS_INT(c)) { int arg1 = AS_INT(b); int arg2 = AS_INT(c); registers[a].type = OBJECT_INT; registers[a].value.i = arg1 + arg2; } else { double arg1 = IS_INT(b) ? (double) AS_INT(b) : AS_REAL(b); double arg2 = IS_INT(c) ? (double) AS_INT(c) : AS_REAL(c); registers[a].type = OBJECT_REAL; registers[a].value.d = arg1 + arg2; } } } break; case OP_SUB: { if (!(IS_INT(b) || IS_REAL(b)) || !(IS_INT(c) || IS_REAL(c))) { fatal("Tried to sub non-numbers."); } if (IS_INT(b) && IS_INT(c)) { int arg1 = AS_INT(b); int arg2 = AS_INT(c); registers[a].type = OBJECT_INT; registers[a].value.i = arg1 - arg2; } else { double arg1 = IS_INT(b) ? (double) AS_INT(b) : AS_REAL(b); double arg2 = IS_INT(c) ? (double) AS_INT(c) : AS_REAL(c); registers[a].type = OBJECT_REAL; registers[a].value.d = arg1 - arg2; } } break; case OP_MUL: { if (!(IS_INT(b) || IS_REAL(b)) || !(IS_INT(c) || IS_REAL(c))) { fatal("Tried to mul non-numbers."); } if (IS_INT(b) && IS_INT(c)) { int arg1 = AS_INT(b); int arg2 = AS_INT(c); registers[a].type = OBJECT_INT; registers[a].value.i = arg1 * arg2; } else { double arg1 = IS_INT(b) ? (double) AS_INT(b) : AS_REAL(b); double arg2 = IS_INT(c) ? (double) AS_INT(c) : AS_REAL(c); registers[a].type = OBJECT_REAL; registers[a].value.d = arg1 * arg2; } } break; case OP_DIV: { if (!(IS_INT(b) || IS_REAL(b)) || !(IS_INT(c) || IS_REAL(c))) { fatal("Tried to div non-numbers."); } if ((IS_INT(c) && AS_INT(c) == 0) || (IS_REAL(c) && AS_REAL(c) == 0)) { fatal("Div by 0."); } if (IS_INT(b) && IS_INT(c)) { int arg1 = AS_INT(b); int arg2 = AS_INT(c); registers[a].type = OBJECT_INT; registers[a].value.i = arg1 / arg2; } else { double arg1 = IS_INT(b) ? (double) AS_INT(b) : AS_REAL(b); double arg2 = IS_INT(c) ? (double) AS_INT(c) : AS_REAL(c); registers[a].type = OBJECT_REAL; registers[a].value.d = arg1 / arg2; } } break; case OP_MOD: { if (!(IS_INT(b) || IS_REAL(b)) || !(IS_INT(c) || IS_REAL(c))) { fatal("Tried to div non-numbers."); } if ((IS_INT(c) && AS_INT(c) == 0) || (IS_REAL(c) && AS_REAL(c) == 0)) { fatal("Mod by 0."); } if (IS_INT(b) && IS_INT(c)) { int arg1 = AS_INT(b); int arg2 = AS_INT(c); registers[a].type = OBJECT_INT; registers[a].value.i = arg1 % arg2; } else { double arg1 = IS_INT(b) ? (double) AS_INT(b) : AS_REAL(b); double arg2 = IS_INT(c) ? (double) AS_INT(c) : AS_REAL(c); registers[a].type = OBJECT_REAL; registers[a].value.i = fmod(arg1, arg2); } } break; case OP_POW: { if (!(IS_INT(b) || IS_REAL(b)) || !(IS_INT(c) || IS_REAL(c))) { fatal("Tried to div non-numbers."); } if (IS_INT(b) && IS_INT(c)) { int arg1 = AS_INT(b); int arg2 = AS_INT(c); registers[a].type = OBJECT_INT; registers[a].value.i = (int) pow(arg1, arg2); } else { double arg1 = IS_INT(b) ? (double) AS_INT(b) : AS_REAL(b); double arg2 = IS_INT(c) ? (double) AS_INT(c) : AS_REAL(c); registers[a].type = OBJECT_REAL; registers[a].value.d = pow(arg1, arg2); } } break; case OP_NEG: { if (IS_INT(b)) { registers[a].type = OBJECT_INT; registers[a].value.i = -AS_INT(b); } else if (IS_REAL(b)) { registers[a].type = OBJECT_INT; registers[a].value.i = -AS_REAL(b); } else { fatal("Tried to negate non-numeric type."); } } break; case OP_NOT: { if (registers[a].type != OBJECT_BOOL) { fatal("Expected boolean type, not %d.", registers[a].type); } registers[a].value.i = registers[a].value.i == 1 ? 0 : 1; } break; case OP_EQ: { if ((IS_INT(b) || IS_REAL(b)) && (IS_INT(c) || IS_REAL(c))) { double arg1 = IS_INT(b) ? (double) AS_INT(b) : AS_REAL(b); double arg2 = IS_INT(c) ? (double) AS_INT(c) : AS_REAL(c); registers[a].type = OBJECT_BOOL; registers[a].value.i = arg1 == arg2; } else { fatal("Comparison of reference types not yet supported."); } } break; case OP_LT: { if (!(IS_INT(b) || IS_REAL(b)) || !(IS_INT(c) || IS_REAL(c))) { fatal("Tried to compare non-numbers."); } double arg1 = IS_INT(b) ? (double) AS_INT(b) : AS_REAL(b); double arg2 = IS_INT(c) ? (double) AS_INT(c) : AS_REAL(c); registers[a].type = OBJECT_BOOL; registers[a].value.i = arg1 < arg2; } break; case OP_LE: { if (!(IS_INT(b) || IS_REAL(b)) || !(IS_INT(c) || IS_REAL(c))) { fatal("Tried to compare non-numbers."); } double arg1 = IS_INT(b) ? (double) AS_INT(b) : AS_REAL(b); double arg2 = IS_INT(c) ? (double) AS_INT(c) : AS_REAL(c); registers[a].type = OBJECT_BOOL; registers[a].value.i = arg1 <= arg2; } break; case OP_CLOSURE: { Closure *child = make_closure(chunk->children[b]); int i; for (i = 0; i < chunk->children[b]->numupvars; i++) { int inst = chunk->instructions[++frame->pc]; OpCode oc = GET_O(inst); int ac = GET_A(inst); int bc = GET_B(inst); int cc = GET_C(inst); if (oc == OP_MOVE) { // first upval for this variable child->upvals[ac] = make_upval(vm, bc); } else { // share upval child->upvals[ac] = closure->upvals[bc]; child->upvals[ac]->refcount++; } } registers[a].value.o = make_closure_ref(vm, child); registers[a].type = OBJECT_REFERENCE; // put this after } break; case OP_CALL: { if (registers[b].type != OBJECT_REFERENCE || registers[b].value.o->type != OBJECT_CLOSURE) { fatal("Tried to call non-closure."); } // TODO - safety issue (see compile.c for notes) Closure *child = registers[b].value.o->value.c; Frame *subframe = make_frame(frame, child); int i; for (i = 0; i < child->chunk->numparams; i++) { copy_object(&subframe->registers[i + 1], ®isters[c + i]); } vm->current = subframe; goto restart; } break; case OP_RETURN: { UpvalNode *head; for (head = vm->open; head != NULL; ) { Upval *u = head->upval; if (u->data.ref.frame == frame) { StackObject *o = malloc(sizeof *o); if (!o) { fatal("Out of memory."); } u->open = 0; copy_object(o, ®isters[u->data.ref.slot]); u->data.o = o; if (vm->open == head) { vm->open = head->next; } else { head->next->prev = head->prev; head->prev->next = head->next; } UpvalNode *temp = head; head = head->next; free(temp); } else { head = head->next; } } if (vm->current->parent != NULL) { Frame *p = vm->current->parent; StackObject *target = &p->registers[GET_A(p->closure->chunk->instructions[p->pc++])]; if (b < 256) { // debug char *d = obj_to_str(®isters[b]); printf("Return value: %s\n", d); free(d); copy_object(target, ®isters[b]); } else { copy_constant(vm, target, chunk->constants[b - 256]); } free_frame(frame); vm->current = p; goto restart; } else { // debug char *d = obj_to_str(®isters[b]); printf("Return value: %s\n", d); free(d); free_frame(frame); vm->current = NULL; return; } } break; case OP_JUMP: frame->pc += c ? -b : b; break; case OP_JUMP_TRUE: { if (registers[a].type != OBJECT_BOOL) { fatal("Expected boolean type, not %d.", registers[a].type); } if (registers[a].value.i == 1) { frame->pc += c ? -b : b; } } break; case OP_JUMP_FALSE: { if (registers[a].type != OBJECT_BOOL) { fatal("Expected boolean type, not %d.", registers[a].type); } if (registers[a].value.i == 0) { frame->pc += c ? -b : b; } } break; case OP_ENTER_TRY: { vm->catchframe = make_catch_frame(frame, vm->catchframe, frame->pc + b); } break; case OP_LEAVE_TRY: { CatchFrame *temp = vm->catchframe; vm->catchframe = vm->catchframe->parent; free_catch_frame(temp); } break; case OP_THROW: { // TODO - replace unwinding of stack with an exceptions // table per-chunk. It will have an instructions range, // the starting instruction of a handler, and the type of // exception that it may handle. // Exception table: // From To Target Type // 0 4 5 Class TestExc1 // 0 12 12 Class TestExc2 // TODO - implement a way to expect an exception // of a given type instead of a generic catch-all. char *s = obj_to_str(®isters[a]); printf("Exception value: %s!\n", s); free(s); // TODO - this is probably wrong. Not sure how complicated // it will be to handle upvalues and frame destruction here, // so we're just doing it a shitty way for now :D [GO LAZE]. if (!vm->catchframe) { // TODO - print a stack trace [ requires debug symbols :( ] fatal("Exception thrown outside of handler."); } while (vm->current != vm->catchframe->frame) { // TODO - destruct frame vm->current = vm->current->parent; } vm->current->pc = vm->catchframe->target; CatchFrame *temp = vm->catchframe; vm->catchframe = vm->catchframe->parent; free_catch_frame(temp); goto restart; } break; } frame->pc++; } fatal("VM left instruction-space."); } }
jv jq_next(jq_state *jq) { jv cfunc_input[MAX_CFUNCTION_ARGS]; uint16_t* pc = stack_restore(jq); assert(pc); int backtracking = !jq->initial_execution; jq->initial_execution = 0; while (1) { uint16_t opcode = *pc; if (jq->debug_trace_enabled) { dump_operation(frame_current_bytecode(&jq->frame_stk), pc); printf("\t"); const struct opcode_description* opdesc = opcode_describe(opcode); data_stk_elem* param = 0; int stack_in = opdesc->stack_in; if (stack_in == -1) stack_in = pc[1]; for (int i=0; i<stack_in; i++) { if (i == 0) { param = forkable_stack_peek(&jq->data_stk); } else { printf(" | "); param = forkable_stack_peek_next(&jq->data_stk, param); } if (!param) break; jv_dump(jv_copy(param->val), 0); //printf("<%d>", jv_get_refcnt(param->val)); //printf(" -- "); //jv_dump(jv_copy(jq->path), 0); } if (backtracking) printf("\t<backtracking>"); printf("\n"); } if (backtracking) { opcode = ON_BACKTRACK(opcode); backtracking = 0; } pc++; switch (opcode) { default: assert(0 && "invalid instruction"); case LOADK: { jv v = jv_array_get(jv_copy(frame_current_bytecode(&jq->frame_stk)->constants), *pc++); assert(jv_is_valid(v)); jv_free(stack_pop(jq)); stack_push(jq, v); break; } case DUP: { jv v = stack_pop(jq); stack_push(jq, jv_copy(v)); stack_push(jq, v); break; } case DUP2: { jv keep = stack_pop(jq); jv v = stack_pop(jq); stack_push(jq, jv_copy(v)); stack_push(jq, keep); stack_push(jq, v); break; } case SUBEXP_BEGIN: { jv v = stack_pop(jq); stack_push(jq, jv_copy(v)); stack_push(jq, v); jq->subexp_nest++; break; } case SUBEXP_END: { assert(jq->subexp_nest > 0); jq->subexp_nest--; jv a = stack_pop(jq); jv b = stack_pop(jq); stack_push(jq, a); stack_push(jq, b); break; } case POP: { jv_free(stack_pop(jq)); break; } case APPEND: { jv v = stack_pop(jq); uint16_t level = *pc++; uint16_t vidx = *pc++; frame_ptr fp = frame_get_level(&jq->frame_stk, frame_current(&jq->frame_stk), level); jv* var = frame_local_var(fp, vidx); assert(jv_get_kind(*var) == JV_KIND_ARRAY); *var = jv_array_append(*var, v); break; } case INSERT: { jv stktop = stack_pop(jq); jv v = stack_pop(jq); jv k = stack_pop(jq); jv objv = stack_pop(jq); assert(jv_get_kind(objv) == JV_KIND_OBJECT); if (jv_get_kind(k) == JV_KIND_STRING) { stack_push(jq, jv_object_set(objv, k, v)); stack_push(jq, stktop); } else { print_error(jv_invalid_with_msg(jv_string_fmt("Cannot use %s as object key", jv_kind_name(jv_get_kind(k))))); jv_free(stktop); jv_free(v); jv_free(k); jv_free(objv); goto do_backtrack; } break; } case ON_BACKTRACK(RANGE): case RANGE: { uint16_t level = *pc++; uint16_t v = *pc++; frame_ptr fp = frame_get_level(&jq->frame_stk, frame_current(&jq->frame_stk), level); jv* var = frame_local_var(fp, v); jv max = stack_pop(jq); if (jv_get_kind(*var) != JV_KIND_NUMBER || jv_get_kind(max) != JV_KIND_NUMBER) { print_error(jv_invalid_with_msg(jv_string_fmt("Range bounds must be numeric"))); jv_free(max); goto do_backtrack; } else if (jv_number_value(jv_copy(*var)) >= jv_number_value(jv_copy(max))) { /* finished iterating */ goto do_backtrack; } else { jv curr = jv_copy(*var); *var = jv_number(jv_number_value(*var) + 1); stack_save(jq, pc - 3); stack_push(jq, jv_copy(max)); stack_switch(jq); stack_push(jq, curr); } break; } // FIXME: loadv/storev may do too much copying/freeing case LOADV: { uint16_t level = *pc++; uint16_t v = *pc++; frame_ptr fp = frame_get_level(&jq->frame_stk, frame_current(&jq->frame_stk), level); jv* var = frame_local_var(fp, v); if (jq->debug_trace_enabled) { printf("V%d = ", v); jv_dump(jv_copy(*var), 0); printf("\n"); } jv_free(stack_pop(jq)); stack_push(jq, jv_copy(*var)); break; } case STOREV: { uint16_t level = *pc++; uint16_t v = *pc++; frame_ptr fp = frame_get_level(&jq->frame_stk, frame_current(&jq->frame_stk), level); jv* var = frame_local_var(fp, v); jv val = stack_pop(jq); if (jq->debug_trace_enabled) { printf("V%d = ", v); jv_dump(jv_copy(val), 0); printf("\n"); } jv_free(*var); *var = val; break; } case PATH_BEGIN: { jv v = stack_pop(jq); stack_push(jq, jq->path); stack_save(jq, pc - 1); stack_switch(jq); stack_push(jq, jv_number(jq->subexp_nest)); stack_push(jq, v); jq->path = jv_array(); jq->subexp_nest = 0; break; } case PATH_END: { jv v = stack_pop(jq); jv_free(v); // discard value, only keep path int old_subexp_nest = (int)jv_number_value(stack_pop(jq)); jv path = jq->path; jq->path = stack_pop(jq); stack_save(jq, pc - 1); stack_push(jq, jv_copy(path)); stack_switch(jq); stack_push(jq, path); jq->subexp_nest = old_subexp_nest; break; } case ON_BACKTRACK(PATH_BEGIN): case ON_BACKTRACK(PATH_END): { jv_free(jq->path); jq->path = stack_pop(jq); goto do_backtrack; } case INDEX: { jv t = stack_pop(jq); jv k = stack_pop(jq); path_append(jq, jv_copy(k)); jv v = jv_get(t, k); if (jv_is_valid(v)) { stack_push(jq, v); } else { print_error(v); goto do_backtrack; } break; } case JUMP: { uint16_t offset = *pc++; pc += offset; break; } case JUMP_F: { uint16_t offset = *pc++; jv t = stack_pop(jq); jv_kind kind = jv_get_kind(t); if (kind == JV_KIND_FALSE || kind == JV_KIND_NULL) { pc += offset; } stack_push(jq, t); // FIXME do this better break; } case EACH: stack_push(jq, jv_number(-1)); // fallthrough case ON_BACKTRACK(EACH): { int idx = jv_number_value(stack_pop(jq)); jv container = stack_pop(jq); int keep_going; jv key, value; if (jv_get_kind(container) == JV_KIND_ARRAY) { if (opcode == EACH) idx = 0; else idx = idx + 1; keep_going = idx < jv_array_length(jv_copy(container)); if (keep_going) { key = jv_number(idx); value = jv_array_get(jv_copy(container), idx); } } else if (jv_get_kind(container) == JV_KIND_OBJECT) { if (opcode == EACH) idx = jv_object_iter(container); else idx = jv_object_iter_next(container, idx); keep_going = jv_object_iter_valid(container, idx); if (keep_going) { key = jv_object_iter_key(container, idx); value = jv_object_iter_value(container, idx); } } else { assert(opcode == EACH); print_error(jv_invalid_with_msg(jv_string_fmt("Cannot iterate over %s", jv_kind_name(jv_get_kind(container))))); keep_going = 0; } if (!keep_going) { jv_free(container); goto do_backtrack; } else { stack_save(jq, pc - 1); stack_push(jq, container); stack_push(jq, jv_number(idx)); stack_switch(jq); path_append(jq, key); stack_push(jq, value); } break; } do_backtrack: case BACKTRACK: { pc = stack_restore(jq); if (!pc) { return jv_invalid(); } backtracking = 1; break; } case FORK: { stack_save(jq, pc - 1); stack_switch(jq); pc++; // skip offset this time break; } case ON_BACKTRACK(FORK): { uint16_t offset = *pc++; pc += offset; break; } case CALL_BUILTIN: { int nargs = *pc++; jv top = stack_pop(jq); cfunc_input[0] = top; for (int i = 1; i < nargs; i++) { cfunc_input[i] = stack_pop(jq); } struct cfunction* func = &frame_current_bytecode(&jq->frame_stk)->globals->cfunctions[*pc++]; top = cfunction_invoke(func, cfunc_input); if (jv_is_valid(top)) { stack_push(jq, top); } else { print_error(top); goto do_backtrack; } break; } case CALL_JQ: { uint16_t nclosures = *pc++; uint16_t* retaddr = pc + 2 + nclosures*2; frame_ptr new_frame = frame_push(&jq->frame_stk, make_closure(&jq->frame_stk, frame_current(&jq->frame_stk), pc), retaddr); pc += 2; frame_ptr old_frame = forkable_stack_peek_next(&jq->frame_stk, new_frame); assert(nclosures == frame_self(new_frame)->bc->nclosures); for (int i=0; i<nclosures; i++) { *frame_closure_arg(new_frame, i) = make_closure(&jq->frame_stk, old_frame, pc); pc += 2; } pc = frame_current_bytecode(&jq->frame_stk)->code; break; } case RET: { uint16_t* retaddr = *frame_current_retaddr(&jq->frame_stk); if (retaddr) { // function return pc = retaddr; frame_pop(&jq->frame_stk); } else { // top-level return, yielding value jv value = stack_pop(jq); stack_save(jq, pc - 1); stack_push(jq, jv_null()); stack_switch(jq); return value; } break; } case ON_BACKTRACK(RET): { // resumed after top-level return goto do_backtrack; } } } }