diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 853bf99f..a14a2886 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -295,9 +295,75 @@ pic_expand(pic_state *pic, pic_value expr, struct pic_env *env) return v; } +static pic_value +optimize_beta(pic_state *pic, pic_value expr) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value functor, formals, args, tmp, val, it, defs; + + if (! pic_list_p(expr)) + return expr; + + if (pic_nil_p(expr)) + return expr; + + if (pic_sym_p(pic_list_ref(pic, expr, 0))) { + pic_sym *sym = pic_sym_ptr(pic_list_ref(pic, expr, 0)); + + if (sym == pic->uQUOTE) { + return expr; + } else if (sym == pic->uLAMBDA) { + return pic_list3(pic, pic_list_ref(pic, expr, 0), pic_list_ref(pic, expr, 1), optimize_beta(pic, pic_list_ref(pic, expr, 2))); + } + } + + tmp = pic_nil_value(); + pic_for_each (val, expr, it) { + pic_push(pic, optimize_beta(pic, val), tmp); + } + expr = pic_reverse(pic, tmp); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, expr); + + functor = pic_list_ref(pic, expr, 0); + if (pic_pair_p(functor) && pic_eq_p(pic_car(pic, functor), pic_obj_value(pic->uLAMBDA))) { + formals = pic_list_ref(pic, functor, 1); + if (! pic_list_p(formals)) + goto exit; /* TODO: support ((lambda args x) 1 2) */ + args = pic_cdr(pic, expr); + if (pic_length(pic, formals) != pic_length(pic, args)) + goto exit; + defs = pic_nil_value(); + pic_for_each (val, args, it) { + pic_push(pic, pic_list3(pic, pic_obj_value(pic->uDEFINE), pic_car(pic, formals), val), defs); + formals = pic_cdr(pic, formals); + } + expr = pic_list_ref(pic, functor, 2); + pic_for_each (val, defs, it) { + expr = pic_list3(pic, pic_obj_value(pic->uBEGIN), val, expr); + } + } + exit: + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, expr); + return expr; +} + +pic_value +pic_optimize(pic_state *pic, pic_value expr) +{ + return optimize_beta(pic, expr); +} + KHASH_DECLARE(a, pic_sym *, int) KHASH_DEFINE2(a, pic_sym *, int, 0, kh_ptr_hash_func, kh_ptr_hash_equal) +/** + * TODO: don't use khash_t, use kvec_t instead + */ + typedef struct analyze_scope { int depth; pic_sym *rest; /* Nullable */ @@ -456,8 +522,14 @@ analyze_lambda(pic_state *pic, analyze_scope *up, pic_value form) } locals = pic_make_vec(pic, kh_size(&scope->locals)); - for (it = kh_begin(&scope->locals), j = 0; it < kh_end(&scope->locals); ++it) { + j = 0; + if (scope->rest != NULL) { + locals->data[j++] = pic_obj_value(scope->rest); + } + for (it = kh_begin(&scope->locals); it < kh_end(&scope->locals); ++it) { if (kh_exist(&scope->locals, it)) { + if (scope->rest != NULL && kh_key(&scope->locals, it) == scope->rest) + continue; locals->data[j++] = pic_obj_value(kh_key(&scope->locals, it)); } } @@ -1045,6 +1117,17 @@ pic_compile(pic_state *pic, pic_value obj, struct pic_env *env) SAVE(pic, ai, obj); + /* optimize */ + obj = pic_optimize(pic, obj); +#if DEBUG + fprintf(stdout, "## optimize completed\n"); + pic_write(pic, obj); + fprintf(stdout, "\n"); + fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); +#endif + + SAVE(pic, ai, obj); + /* analyze */ obj = pic_analyze(pic, obj); #if DEBUG diff --git a/extlib/benz/include/picrin/opcode.h b/extlib/benz/include/picrin/opcode.h index e3eb00a7..9bff2cdd 100644 --- a/extlib/benz/include/picrin/opcode.h +++ b/extlib/benz/include/picrin/opcode.h @@ -60,7 +60,6 @@ enum pic_opcode { PIC_INLINE void pic_dump_code(pic_code c) { - printf("[%2d] ", c.insn); switch (c.insn) { case OP_NOP: puts("OP_NOP"); @@ -187,7 +186,7 @@ pic_dump_irep(struct pic_irep *irep) printf("## irep %p\n", (void *)irep); printf("[clen = %zd, argc = %d, localc = %d, capturec = %d]\n", irep->clen, irep->argc, irep->localc, irep->capturec); for (i = 0; i < irep->clen; ++i) { - printf("%02x ", i); + printf("%02x: ", i); pic_dump_code(irep->code[i]); } diff --git a/extlib/benz/include/picrin/pair.h b/extlib/benz/include/picrin/pair.h index a05b23b6..44233aa7 100644 --- a/extlib/benz/include/picrin/pair.h +++ b/extlib/benz/include/picrin/pair.h @@ -24,7 +24,7 @@ pic_car(pic_state *pic, pic_value obj) struct pic_pair *pair; if (! pic_pair_p(obj)) { - pic_errorf(pic, "pair required, but got ~s", obj); + pic_errorf(pic, "car: pair required, but got ~s", obj); } pair = pic_pair_ptr(obj); @@ -37,7 +37,7 @@ pic_cdr(pic_state *pic, pic_value obj) struct pic_pair *pair; if (! pic_pair_p(obj)) { - pic_errorf(pic, "pair required, but got ~s", obj); + pic_errorf(pic, "cdr: pair required, but got ~s", obj); } pair = pic_pair_ptr(obj);