Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-15 00:47:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Making exceptions properly thread-local.

Browse source
This commit is contained in:
Alex Shinn 2011-12-25 16:28:53 +09:00
parent 87970984c7
commit 52a3f55721
6 changed files with 85 additions and 47 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
eval.c
View file

@ -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);

4
include/chibi/eval.h
View file

@ -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);

17
lib/chibi/repl.scm
View file

@ -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

78
lib/init-7.scm
View file

@ -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

17
lib/srfi/39/param.c
View file

@ -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;
}

2
opcodes.c
View file

@ -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