diff --git a/eval.c b/eval.c index 69517750..6958b9ee 100644 --- a/eval.c +++ b/eval.c @@ -200,6 +200,7 @@ static sexp finalize_bytecode (sexp ctx) { else sexp_bytecode_literals(bc) = sexp_list_to_vector(ctx, sexp_bytecode_literals(bc)); } + /* sexp_disasm(ctx, bc, sexp_current_error_port(ctx)); */ return bc; } @@ -277,19 +278,20 @@ static sexp sexp_make_lit (sexp ctx, sexp value) { #define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*SEXP_INIT_STACK_SIZE) void sexp_init_eval_context_globals (sexp ctx) { + sexp_gc_var2(bc, vec); ctx = sexp_make_child_context(ctx, NULL); + sexp_gc_preserve2(ctx, bc, vec); emit(ctx, OP_RESUMECC); sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = finalize_bytecode(ctx); ctx = sexp_make_child_context(ctx, NULL); emit(ctx, OP_DONE); + bc = finalize_bytecode(ctx); + vec = sexp_make_vector(ctx, 0, SEXP_VOID); sexp_global(ctx, SEXP_G_FINAL_RESUMER) - = sexp_make_procedure(ctx, - sexp_make_fixnum(0), - sexp_make_fixnum(0), - finalize_bytecode(ctx), - sexp_make_vector(ctx, 0, SEXP_VOID)); + = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, bc, vec); sexp_bytecode_name(sexp_procedure_code(sexp_global(ctx, SEXP_G_FINAL_RESUMER))) = sexp_intern(ctx, "final-resumer"); + sexp_gc_release2(ctx); } sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env) { @@ -842,8 +844,7 @@ static void generate_set (sexp ctx, sexp set) { emit(ctx, OP_SET_CDR); } else { lambda = sexp_ref_loc(ref); - if (sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)) - != SEXP_FALSE) { + if (sexp_truep(sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)))) { /* stack or closure mutable vars are boxed */ generate_ref(ctx, ref, 0); emit(ctx, OP_SET_CDR); @@ -1013,7 +1014,7 @@ static void generate_lambda (sexp ctx, sexp lambda) { sexp_bytecode_name(bc) = sexp_lambda_name(lambda); if (sexp_nullp(fv)) { /* shortcut, no free vars */ - tmp = sexp_make_vector(ctx2, sexp_make_fixnum(0), SEXP_VOID); + tmp = sexp_make_vector(ctx2, SEXP_ZERO, SEXP_VOID); tmp = sexp_make_procedure(ctx2, flags, len, bc, tmp); sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), tmp); generate_lit(ctx, tmp); @@ -1161,8 +1162,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { generate_opcode_app(ctx2, refs); bc = finalize_bytecode(ctx2); sexp_bytecode_name(bc) = sexp_c_string(ctx2, sexp_opcode_name(op), -1); - res = sexp_make_procedure(ctx2, sexp_make_fixnum(0), sexp_make_fixnum(i), - bc, SEXP_VOID); + res=sexp_make_procedure(ctx2, SEXP_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID); if (i == sexp_opcode_num_args(op)) sexp_opcode_proc(op) = res; sexp_gc_release5(ctx); @@ -1268,20 +1268,18 @@ sexp sexp_vm (sexp ctx, sexp proc) { _ARG1 = tmp1; break; case OP_CALLCC: - stack[top] = sexp_make_fixnum(1); + stack[top] = SEXP_ONE; stack[top+1] = sexp_make_fixnum(ip-sexp_bytecode_data(bc)); stack[top+2] = self; stack[top+3] = sexp_make_fixnum(fp); tmp1 = _ARG1; i = 1; sexp_context_top(ctx) = top; - tmp2 = sexp_make_vector(ctx, sexp_make_fixnum(1), SEXP_UNDEF); - sexp_vector_set(tmp2, - sexp_make_fixnum(0), - sexp_save_stack(ctx, stack, top+4)); + tmp2 = sexp_make_vector(ctx, SEXP_ONE, SEXP_UNDEF); + sexp_vector_set(tmp2, SEXP_ZERO, sexp_save_stack(ctx, stack, top+4)); _ARG1 = sexp_make_procedure(ctx, - sexp_make_fixnum(0), - sexp_make_fixnum(1), + SEXP_ZERO, + SEXP_ONE, sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE), tmp2); top++; @@ -1686,7 +1684,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { top--; break; case OP_DIV: - if (_ARG2 == sexp_make_fixnum(0)) { + if (_ARG2 == SEXP_ZERO) { #if USE_FLONUMS if (sexp_flonump(_ARG1) && sexp_flonum_value(_ARG1) == 0.0) _ARG2 = sexp_make_flonum(ctx, 0.0/0.0); @@ -1722,7 +1720,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { break; case OP_QUOTIENT: if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { - if (_ARG2 == sexp_make_fixnum(0)) + if (_ARG2 == SEXP_ZERO) sexp_raise("divide by zero", SEXP_NULL); _ARG2 = sexp_fx_div(_ARG1, _ARG2); top--; @@ -1738,7 +1736,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { break; case OP_REMAINDER: if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { - if (_ARG2 == sexp_make_fixnum(0)) + if (_ARG2 == SEXP_ZERO) sexp_raise("divide by zero", SEXP_NULL); tmp1 = sexp_fx_rem(_ARG1, _ARG2); top--; @@ -2117,9 +2115,9 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) { sexp res; #if USE_BIGNUMS if (sexp_bignump(e)) { /* bignum exponent needs special handling */ - if ((x == sexp_make_fixnum(0)) || (x == sexp_make_fixnum(-1))) + if ((x == SEXP_ZERO) || (x == SEXP_NEG_ONE)) res = sexp_make_flonum(ctx, pow(0, 0)); /* +nan.0 */ - else if (x == sexp_make_fixnum(1)) + else if (x == SEXP_ONE) res = sexp_make_flonum(ctx, 1); /* 1.0 */ else if (sexp_flonump(x)) res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e))); @@ -2187,6 +2185,21 @@ static sexp sexp_string_cmp (sexp ctx, sexp str1, sexp str2, sexp ci) { #include "opt/plan9.c" #endif +/************************** optimizations *****************************/ + +static sexp sexp_apply_optimization (sexp ctx, sexp proc, sexp ast) { + sexp res; + sexp_gc_var1(args); + if (sexp_opcodep(proc)) { + res = ((sexp_proc2)sexp_opcode_func(proc))(ctx, ast); + } else { + sexp_gc_preserve1(ctx, args); + res = sexp_apply(ctx, proc, args=sexp_list1(ctx, ast)); + sexp_gc_release1(ctx); + } + return res; +} + /*********************** standard environment *************************/ static struct sexp_struct core_forms[] = { @@ -2290,10 +2303,8 @@ sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type) { if (! sexp_fixnump(type)) return sexp_type_exception(ctx, "make-type-predicate: bad type", type); return sexp_make_opcode(ctx, name, sexp_make_fixnum(OPC_TYPE_PREDICATE), - sexp_make_fixnum(OP_TYPEP), sexp_make_fixnum(1), - sexp_make_fixnum(0), sexp_make_fixnum(0), - sexp_make_fixnum(0), sexp_make_fixnum(0), type, - NULL, NULL); + sexp_make_fixnum(OP_TYPEP), SEXP_ONE, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL); } sexp sexp_make_constructor (sexp ctx, sexp name, sexp type) { @@ -2302,9 +2313,8 @@ sexp sexp_make_constructor (sexp ctx, sexp name, sexp type) { return sexp_type_exception(ctx, "make-constructor: bad type", type); type_size = sexp_type_size_base(&(sexp_type_specs[sexp_unbox_fixnum(type)])); return sexp_make_opcode(ctx, name, sexp_make_fixnum(OPC_CONSTRUCTOR), - sexp_make_fixnum(OP_MAKE), sexp_make_fixnum(0), - sexp_make_fixnum(0), sexp_make_fixnum(0), - sexp_make_fixnum(0), sexp_make_fixnum(0), type, + sexp_make_fixnum(OP_MAKE), SEXP_ZERO, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, sexp_make_fixnum(type_size), NULL); } @@ -2316,8 +2326,7 @@ sexp sexp_make_accessor (sexp ctx, sexp name, sexp type, sexp index, sexp code) return sexp_make_opcode(ctx, name, sexp_make_fixnum(OPC_ACCESSOR), code, sexp_make_fixnum(sexp_unbox_fixnum(code)==OP_SLOT_REF?1:2), - sexp_make_fixnum(0), type, sexp_make_fixnum(0), - sexp_make_fixnum(0), type, index, NULL); + SEXP_ZERO, type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); } sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index) { @@ -2376,6 +2385,7 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { tmp = sexp_list1(ctx, sym=sexp_intern(ctx, sexp_platform)); sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi")); sexp_env_define(ctx, e, sexp_intern(ctx, "*features*"), tmp); + sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; sexp_gc_release4(ctx); return e; } @@ -2426,9 +2436,9 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { stack[--offset] = sexp_car(ls); stack[top] = sexp_make_fixnum(len); top++; - stack[top++] = sexp_make_fixnum(0); + stack[top++] = SEXP_ZERO; stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); - stack[top++] = sexp_make_fixnum(0); + stack[top++] = SEXP_ZERO; sexp_context_top(ctx) = top; res = sexp_vm(ctx, proc); if (! res) res = SEXP_VOID; @@ -2443,12 +2453,16 @@ sexp sexp_compile (sexp ctx, sexp x) { if (sexp_exceptionp(ast)) { res = ast; } else { +#if USE_SIMPLIFY + res = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); + for ( ; sexp_pairp(res); res=sexp_cdr(res)) + ast = sexp_apply_optimization(ctx, sexp_cdar(res), ast); +#endif free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ generate(ctx, ast); res = finalize_bytecode(ctx); vec = sexp_make_vector(ctx, 0, SEXP_VOID); - res = sexp_make_procedure(ctx, sexp_make_fixnum(0), sexp_make_fixnum(0), - res, vec); + res = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, res, vec); } sexp_gc_release3(ctx); return res; diff --git a/include/chibi/config.h b/include/chibi/config.h index 61dd03b2..779847af 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -12,6 +12,9 @@ /* sexp_init_library(ctx, env) function provided. */ /* #define USE_DL 0 */ +/* uncomment this to disable a simplifying optimization pass */ +/* #define USE_SIMPLIFY 0 */ + /* uncomment this to disable dynamic type definitions */ /* This enables register-simple-type and related */ /* opcodes for defining types, needed by the default */ @@ -161,6 +164,10 @@ #endif #endif +#ifndef USE_SIMPLIFY +#define USE_SIMPLIFY 1 +#endif + #ifndef USE_BOEHM #define USE_BOEHM 0 #endif diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 88ae48d9..9e58e0b9 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -455,6 +455,12 @@ sexp sexp_make_flonum(sexp ctx, double f); #define sexp_make_fixnum(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_FIXNUM_BITS) +#define SEXP_NEG_ONE sexp_make_fixnum(-1) +#define SEXP_ZERO sexp_make_fixnum(0) +#define SEXP_ONE sexp_make_fixnum(1) +#define SEXP_TWO sexp_make_fixnum(2) +#define SEXP_THREE sexp_make_fixnum(3) + #define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_EXTENDED_BITS)) @@ -576,6 +582,7 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #define sexp_opcode_variadic_p(x) (sexp_opcode_flags(x) & 1) #define sexp_opcode_opt_param_p(x) (sexp_opcode_flags(x) & 2) +#define sexp_opcode_ref_trans_p(x) (sexp_opcode_flags(x) & 4) #define sexp_lambda_name(x) ((x)->value.lambda.name) #define sexp_lambda_params(x) ((x)->value.lambda.params) diff --git a/opt/debug.c b/opt/debug.c index 6d8b5de6..97d46d7b 100644 --- a/opt/debug.c +++ b/opt/debug.c @@ -28,7 +28,13 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { } else if (! sexp_bytecodep(bc)) { return sexp_type_exception(ctx, "not a procedure", bc); } + if (! sexp_oportp(out)) + return SEXP_VOID; ip = sexp_bytecode_data(bc); + sexp_write_string(ctx, "-------------- ", out); + if (sexp_truep(sexp_bytecode_name(bc))) + sexp_write(ctx, sexp_bytecode_name(bc), out); + sexp_write_char(ctx, '\n', out); loop: opcode = *ip++; if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) { @@ -43,14 +49,16 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { case OP_CLOSURE_REF: case OP_JUMP: case OP_JUMP_UNLESS: + case OP_TYPEP: case OP_FCALL0: case OP_FCALL1: case OP_FCALL2: case OP_FCALL3: - case OP_TYPEP: sexp_printf(ctx, out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); ip += sizeof(sexp); break; + ip += sizeof(sexp); + break; case OP_SLOT_REF: case OP_SLOT_SET: case OP_MAKE: diff --git a/sexp.c b/sexp.c index 2432c264..f6d9d529 100644 --- a/sexp.c +++ b/sexp.c @@ -154,9 +154,8 @@ sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots) { short type_size = sexp_sizeof_header + sizeof(sexp)*sexp_unbox_fixnum(slots); return sexp_register_type(ctx, name, sexp_make_fixnum(sexp_offsetof_slot0), - slots, slots, sexp_make_fixnum(0), sexp_make_fixnum(0), - sexp_make_fixnum(type_size), sexp_make_fixnum(0), - sexp_make_fixnum(0), NULL); + slots, slots, SEXP_ZERO, SEXP_ZERO, + sexp_make_fixnum(type_size), SEXP_ZERO, SEXP_ZERO, NULL); } sexp sexp_finalize_c_type (sexp ctx, sexp obj) { @@ -323,8 +322,7 @@ sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) { } if (sexp_pairp(sexp_exception_source(exn))) { ls = sexp_exception_source(exn); - if (sexp_fixnump(sexp_cdr(ls)) - && (sexp_cdr(ls) >= sexp_make_fixnum(0))) { + if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { sexp_write_string(ctx, " on line ", out); sexp_write(ctx, sexp_cdr(ls), out); } @@ -743,8 +741,8 @@ sexp sexp_make_cpointer (sexp ctx, sexp_uint_t typeid, void *value, sexp parent, #if SEXP_BSD -#define sexp_stream_ctx(vec) sexp_vector_ref((sexp)vec, sexp_make_fixnum(0)) -#define sexp_stream_buf(vec) sexp_vector_ref((sexp)vec, sexp_make_fixnum(1)) +#define sexp_stream_ctx(vec) sexp_vector_ref((sexp)vec, SEXP_ZERO) +#define sexp_stream_buf(vec) sexp_vector_ref((sexp)vec, SEXP_ONE) #define sexp_stream_size(vec) sexp_vector_ref((sexp)vec, sexp_make_fixnum(2)) #define sexp_stream_pos(vec) sexp_vector_ref((sexp)vec, sexp_make_fixnum(3)) @@ -801,7 +799,7 @@ sexp sexp_make_input_string_port (sexp ctx, sexp str) { sexp_stream_ctx(cookie) = ctx; sexp_stream_buf(cookie) = str; sexp_stream_size(cookie) = sexp_make_fixnum(sexp_string_length(str)); - sexp_stream_pos(cookie) = sexp_make_fixnum(0); + sexp_stream_pos(cookie) = SEXP_ZERO; in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL); res = sexp_make_input_port(ctx, in, SEXP_FALSE); sexp_port_cookie(res) = cookie; @@ -819,7 +817,7 @@ sexp sexp_make_output_string_port (sexp ctx) { sexp_stream_ctx(cookie) = ctx; sexp_stream_buf(cookie) = sexp_make_string(ctx, size, SEXP_VOID); sexp_stream_size(cookie) = size; - sexp_stream_pos(cookie) = sexp_make_fixnum(0); + sexp_stream_pos(cookie) = SEXP_ZERO; out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL); res = sexp_make_output_port(ctx, out, SEXP_FALSE); sexp_port_cookie(res) = cookie; @@ -832,7 +830,7 @@ sexp sexp_get_output_string (sexp ctx, sexp port) { fflush(sexp_port_stream(port)); return sexp_substring(ctx, sexp_stream_buf(cookie), - sexp_make_fixnum(0), + SEXP_ZERO, sexp_stream_pos(cookie)); } @@ -1530,7 +1528,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { sexp_bignum_sign(res) = -sexp_bignum_sign(res); else #endif - res = sexp_fx_mul(res, sexp_make_fixnum(-1)); + res = sexp_fx_mul(res, SEXP_NEG_ONE); } } else { sexp_push_char(ctx, c2, in);