From c01721e11086931b0c536f55cbd38b101af5838f Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 18 Nov 2010 21:37:46 -0800 Subject: [PATCH] Replacing eval opcode with compile + normal application. --- eval.c | 27 ++++++++++++++++----------- include/chibi/eval.h | 1 + lib/chibi/repl.scm | 16 +++++++++++----- lib/init.scm | 3 +++ opcodes.c | 2 +- vm.c | 4 ++-- 6 files changed, 34 insertions(+), 19 deletions(-) diff --git a/eval.c b/eval.c index 8a7c9b3d..e3e37d57 100644 --- a/eval.c +++ b/eval.c @@ -1743,22 +1743,27 @@ sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, se /************************** eval interface ****************************/ -sexp sexp_compile (sexp ctx, sexp x) { +sexp sexp_compile_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp env) { sexp_gc_var3(ast, vec, res); sexp_gc_preserve3(ctx, ast, vec, res); - ast = sexp_analyze(ctx, x); + sexp ctx2; + if (! env) env = sexp_context_env(ctx); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), env, 0); + sexp_context_child(ctx) = ctx2; + ast = sexp_analyze(ctx2, obj); if (sexp_exceptionp(ast)) { res = ast; } else { - res = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); + res = sexp_global(ctx2, SEXP_G_OPTIMIZATIONS); for ( ; sexp_pairp(res); res=sexp_cdr(res)) - ast = sexp_apply1(ctx, sexp_cdar(res), ast); - sexp_free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ - emit_enter(ctx); - generate(ctx, ast); - res = finalize_bytecode(ctx); - vec = sexp_make_vector(ctx, 0, SEXP_VOID); - res = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, res, vec); + ast = sexp_apply1(ctx2, sexp_cdar(res), ast); + sexp_free_vars(ctx2, ast, SEXP_NULL); /* should return SEXP_NULL */ + emit_enter(ctx2); + generate(ctx2, ast); + res = finalize_bytecode(ctx2); + vec = sexp_make_vector(ctx2, 0, SEXP_VOID); + res = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, vec); } sexp_gc_release3(ctx); return res; @@ -1776,7 +1781,7 @@ sexp sexp_eval_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp env) { sexp_context_params(ctx) = SEXP_NULL; ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), env, 0); sexp_context_child(ctx) = ctx2; - res = sexp_compile(ctx2, obj); + res = sexp_compile_op(ctx2, self, n, obj, env); if (! sexp_exceptionp(res)) res = sexp_apply(ctx2, res, SEXP_NULL); sexp_context_child(ctx) = SEXP_FALSE; diff --git a/include/chibi/eval.h b/include/chibi/eval.h index daa7aea2..33f73624 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -140,6 +140,7 @@ SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); SEXP_API sexp sexp_apply1 (sexp ctx, sexp f, sexp x); SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv); SEXP_API int sexp_param_index (sexp lambda, sexp name); +SEXP_API sexp sexp_compile_op (sexp context sexp_api_params(self, n), sexp obj, sexp env); SEXP_API sexp sexp_eval_op (sexp context sexp_api_params(self, n), sexp obj, sexp env); SEXP_API sexp sexp_eval_string (sexp context, const char *str, sexp_sint_t len, sexp env); SEXP_API sexp sexp_load_op (sexp context sexp_api_params(self, n), sexp expr, sexp env); diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm index 634271e4..d9ae63e9 100644 --- a/lib/chibi/repl.scm +++ b/lib/chibi/repl.scm @@ -37,13 +37,19 @@ (let* ((expr (call-with-input-string line read/ss)) (thread (make-thread (lambda () - (let ((res (eval expr env))) - (if (not (eq? res (if #f #f))) - (write/ss res)) - (newline)))))) + (handle-exceptions + exn + (print-exception exn (current-error-port)) + (let ((res (eval expr env))) + (cond + ((not (eq? res (if #f #f))) + (write/ss res) + (newline))))))))) (with-signal-handler signal/interrupt - (lambda (n) (thread-terminate! thread)) + (lambda (n) + (display "Interrupt\n" (current-error-port)) + (thread-terminate! thread)) (lambda () (thread-join! (thread-start! thread)))))) (lp module env))))))) diff --git a/lib/init.scm b/lib/init.scm index 0df5cb0a..ecb8771b 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -65,6 +65,9 @@ (apply1 proc (append2 (reverse (cdr lol)) (car lol)))) (reverse args)))) +(define (eval x . o) + ((compile x (if (pair? o) (car o) (interaction-environment))))) + ;; map with a fast-path for single lists (define (map proc ls . lol) diff --git a/opcodes.c b/opcodes.c index 8c0ea700..e7a13eee 100644 --- a/opcodes.c +++ b/opcodes.c @@ -111,7 +111,7 @@ _FN1(SEXP_VOID, _I(SEXP_OPORT), "close-output-port", 0, sexp_close_port_op), _FN0(_I(SEXP_ENV), "make-environment", 0, sexp_make_env_op), _FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "null-environment", 0, sexp_make_null_env_op), _FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "scheme-report-environment", 0, sexp_make_standard_env_op), -_FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_ENV), "eval", (sexp)"interaction-environment", sexp_eval_op), +_FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_ENV), "compile", (sexp)"interaction-environment", sexp_compile_op), _FN2OPTP(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_ENV), "load", (sexp)"interaction-environment", sexp_load_op), _FN4(SEXP_VOID, _I(SEXP_ENV), _I(SEXP_ENV), _I(SEXP_OBJECT), "%env-copy!", 0, sexp_env_copy_op), _FN2(SEXP_VOID, _I(SEXP_EXCEPTION), _I(SEXP_OPORT), "print-exception", 0, sexp_print_exception_op), diff --git a/vm.c b/vm.c index 3d8a8267..b019acfb 100644 --- a/vm.c +++ b/vm.c @@ -659,7 +659,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { goto make_call; case SEXP_OP_TAIL_CALL: _ALIGN_IP(); - i = sexp_unbox_fixnum(_WORD0); /* number of params */ + i = sexp_unbox_fixnum(_WORD0); /* number of params */ tmp1 = _ARG1; /* procedure to call */ /* save frame info */ tmp2 = stack[fp+3]; @@ -734,8 +734,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { fp = top-4; break; case SEXP_OP_FCALL0: - tmp1 = _WORD0; _ALIGN_IP(); + tmp1 = _WORD0; sexp_context_top(ctx) = top; sexp_context_last_fp(ctx) = fp; _PUSH(((sexp_proc1)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 0)));