From 52a3f55721c629f380ebfcc8a6f5ab22b652ff08 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 25 Dec 2011 16:28:53 +0900 Subject: [PATCH] Making exceptions properly thread-local. --- eval.c | 14 +++++++- include/chibi/eval.h | 4 ++- lib/chibi/repl.scm | 17 +++++++--- lib/init-7.scm | 78 ++++++++++++++++++++++++++++++-------------- lib/srfi/39/param.c | 17 ---------- opcodes.c | 2 ++ 6 files changed, 85 insertions(+), 47 deletions(-) diff --git a/eval.c b/eval.c index 54b96c41..b165eb45 100644 --- a/eval.c +++ b/eval.c @@ -1899,7 +1899,7 @@ sexp sexp_parameter_ref (sexp ctx, sexp param) { } #if SEXP_USE_GREEN_THREADS -sexp sexp_dk (sexp ctx, sexp self, sexp_uint_t n, sexp val) { +sexp sexp_dk (sexp ctx, sexp self, sexp_sint_t n, sexp val) { if (sexp_not(val)) { return sexp_context_dk(ctx) ? sexp_context_dk(ctx) : SEXP_FALSE; } else { @@ -1907,6 +1907,16 @@ sexp sexp_dk (sexp ctx, sexp self, sexp_uint_t n, sexp val) { return SEXP_VOID; } } + +sexp sexp_thread_parameters (sexp ctx, sexp self, sexp_sint_t n) { + sexp res = sexp_context_params(ctx); + return res ? res : SEXP_NULL; +} + +sexp sexp_thread_parameters_set (sexp ctx, sexp self, sexp_sint_t n, sexp new) { + sexp_context_params(ctx) = new; + return SEXP_VOID; +} #endif void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value) { @@ -2116,6 +2126,7 @@ sexp sexp_compile_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp env) { sexp_gc_preserve3(ctx, ast, vec, res); ctx2 = sexp_make_eval_context(ctx, NULL, env, 0, 0); sexp_context_child(ctx) = ctx2; + sexp_context_dk(ctx2) = sexp_list1(ctx2, SEXP_FALSE); ast = sexp_analyze(ctx2, obj); if (sexp_exceptionp(ast)) { res = ast; @@ -2147,6 +2158,7 @@ sexp sexp_eval_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp env) { sexp_context_params(ctx) = SEXP_NULL; ctx2 = sexp_make_eval_context(ctx, NULL, env, 0, 0); sexp_context_child(ctx) = ctx2; + sexp_context_dk(ctx2) = sexp_list1(ctx, SEXP_FALSE); res = sexp_compile_op(ctx2, self, n, obj, env); if (! sexp_exceptionp(res)) res = sexp_apply(ctx2, res, SEXP_NULL); diff --git a/include/chibi/eval.h b/include/chibi/eval.h index afe6c5f6..5d0ce13a 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -88,7 +88,9 @@ SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, SEXP_API sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags, sexp num_args, sexp bc, sexp vars); SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); #if SEXP_USE_GREEN_THREADS -SEXP_API sexp sexp_dk (sexp ctx, sexp self, sexp_uint_t n, sexp val); +SEXP_API sexp sexp_dk (sexp ctx, sexp self, sexp_sint_t n, sexp val); +SEXP_API sexp sexp_thread_parameters (sexp ctx, sexp self, sexp_sint_t n); +SEXP_API sexp sexp_thread_parameters_set (sexp ctx, sexp self, sexp_sint_t n, sexp val); #endif #if SEXP_USE_UTF8_STRINGS SEXP_API int sexp_utf8_initial_byte_count (int c); diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm index 8fe911cc..14d2de40 100644 --- a/lib/chibi/repl.scm +++ b/lib/chibi/repl.scm @@ -196,11 +196,14 @@ (else (fail "unknown repl command:" op)))))))) (else - (guard - (exn - (else (print-exception exn (current-error-port)))) + ;; The outer guard in the parent thread catches read + ;; errors and errors in the repl logic itself. + (guard (exn (else (print-exception exn (current-error-port)))) (let* ((expr (call-with-input-string line (lambda (in2) + ;; Ugly wrapper to account for the + ;; implicit state mutation implied by + ;; the #!fold-case read syntax. (set-port-fold-case! in2 (port-fold-case? in)) (let ((expr (read/ss in2))) (set-port-fold-case! in (port-fold-case? in2)) @@ -208,20 +211,26 @@ (thread (make-thread (lambda () + ;; The inner guard in the child thread + ;; catches errors from eval. (guard (exn - (else (print-exception exn (current-error-port)))) + (else (print-exception exn (current-output-port)))) (let ((res (eval expr env))) (cond ((not (eq? res (if #f #f))) (write/ss res) (newline))))))))) + ;; If an interrupt occurs while the child thread is + ;; still running, terminate it, otherwise wait for it + ;; to complete. (with-signal-handler signal/interrupt (lambda (n) (display "Interrupt\n" (current-error-port)) (thread-terminate! thread)) (lambda () (thread-join! (thread-start! thread)))))) + ;; Loop whether there were errors or interrupts or not. (lp module env meta-env))))))) (if history-file (call-with-output-file history-file diff --git a/lib/init-7.scm b/lib/init-7.scm index 964078a1..8093e446 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -65,9 +65,6 @@ (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) @@ -844,38 +841,71 @@ (define (raise-continuable exn) (raise (list *continuable* exn))) +(define (%with-exception-handler handler thunk) + (let* ((old (thread-parameters)) + (new (cons (cons current-exception-handler handler) old))) + (dynamic-wind + (lambda () (thread-parameters-set! new)) + thunk + (lambda () (thread-parameters-set! old))))) + (define (with-exception-handler handler thunk) (letrec ((orig-handler (current-exception-handler)) (self (lambda (exn) - (current-exception-handler orig-handler) - (dynamic-wind - (lambda () (current-exception-handler orig-handler)) + (%with-exception-handler orig-handler (lambda () (cond ((and (pair? exn) (eq? *continuable* (car exn))) (handler (cadr exn))) (else (handler exn) - (error "exception handler returned")))) - (lambda () (current-exception-handler self)))))) - (dynamic-wind - (lambda () (current-exception-handler self)) - thunk - (lambda () (current-exception-handler orig-handler))))) + (error "exception handler returned")))))))) + (%with-exception-handler self thunk))) (define-syntax guard - (syntax-rules (else) - ((guard (var (test . handler) ... (else . else-handler)) body ...) - (call-with-current-continuation - (lambda (return) - (with-exception-handler - (lambda (var) - (return - (cond (test . handler) ... - (else . else-handler)))) - (lambda () body ...))))) - ((guard (var (test . handler) ...) body ...) - (guard (var (test . handler) ... (else (raise var))) body ...)))) + (syntax-rules () + ((guard (var clause ...) e1 e2 ...) + ((call-with-current-continuation + (lambda (guard-k) + (with-exception-handler + (lambda (condition) + ((call-with-current-continuation + (lambda (handler-k) + (guard-k + (lambda () + (let ((var condition)) + (guard-aux (handler-k (lambda () + (raise-continuable condition))) + clause ...)))))))) + (lambda () + (call-with-values (lambda () e1 e2 ...) + (lambda args + (guard-k (lambda () (apply values args))))))))))))) + +(define-syntax guard-aux + (syntax-rules (else =>) + ((guard-aux reraise (else result1 result2 ...)) + (begin result1 result2 ...)) + ((guard-aux reraise (test => result)) + (let ((temp test)) + (if temp (result temp) reraise))) + ((guard-aux reraise (test => result) clause1 clause2 ...) + (let ((temp test)) + (if temp (result temp) (guard-aux reraise clause1 clause2 ...)))) + ((guard-aux reraise (test)) + test) + ((guard-aux reraise (test) clause1 clause2 ...) + (or test (guard-aux reraise clause1 clause2 ...))) + ((guard-aux reraise (test result1 result2 ...)) + (if test (begin result1 result2 ...) reraise)) + ((guard-aux reraise (test result1 result2 ...) clause1 clause2 ...) + (if test + (begin result1 result2 ...) + (guard-aux reraise clause1 clause2 ...))))) + +(define (eval x . o) + (let ((thunk (compile x (if (pair? o) (car o) (interaction-environment))))) + (if (procedure? thunk) (thunk) (raise thunk)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; promises diff --git a/lib/srfi/39/param.c b/lib/srfi/39/param.c index 392d8649..02da69bc 100644 --- a/lib/srfi/39/param.c +++ b/lib/srfi/39/param.c @@ -26,18 +26,6 @@ static sexp sexp_parameter_converter (sexp ctx, sexp self, sexp_sint_t n, sexp p return res ? res : SEXP_FALSE; } -#if SEXP_USE_GREEN_THREADS -static sexp sexp_thread_parameters (sexp ctx, sexp self, sexp_sint_t n) { - sexp res = sexp_context_params(ctx); - return res ? res : SEXP_NULL; -} - -static sexp sexp_thread_parameters_set (sexp ctx, sexp self, sexp_sint_t n, sexp new) { - sexp_context_params(ctx) = new; - return SEXP_VOID; -} -#endif - sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, sexp_abi_identifier_t abi) { if (!(sexp_version_compatible(ctx, version, sexp_version) && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER))) @@ -46,11 +34,6 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char sexp_define_foreign(ctx, env, "%make-parameter", 2, sexp_make_parameter); sexp_define_foreign(ctx, env, "parameter-converter", 1, sexp_parameter_converter); -#if SEXP_USE_GREEN_THREADS - sexp_define_foreign(ctx, env, "thread-parameters", 0, sexp_thread_parameters); - sexp_define_foreign(ctx, env, "thread-parameters-set!", 1, sexp_thread_parameters_set); -#endif - return SEXP_VOID; } diff --git a/opcodes.c b/opcodes.c index 559ce331..0173c83c 100644 --- a/opcodes.c +++ b/opcodes.c @@ -227,6 +227,8 @@ _FN2(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_BOOLEAN), "add-module-directory", 0, se #endif #if SEXP_USE_GREEN_THREADS _FN1OPT(_I(SEXP_OBJECT), _I(SEXP_OBJECT), "%dk", SEXP_FALSE, sexp_dk), +_FN0(_I(SEXP_OBJECT), "thread-parameters", 0, sexp_thread_parameters), +_FN1(_I(SEXP_OBJECT), _I(SEXP_OBJECT), "thread-parameters-set!", 0, sexp_thread_parameters_set), _OP(SEXP_OPC_GENERIC, SEXP_OP_YIELD, 0, 0, SEXP_VOID, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, 0, "yield!", 0, NULL), #endif #if SEXP_USE_PROFILE_VM