From 60c4007e6f81a46bca743459a2c027991d59cb8e Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 25 Aug 2020 14:09:29 +0900 Subject: [PATCH] adding thread-interrupt! so that (chibi repl) can preserve continuations (issue #686) --- include/chibi/sexp.h | 4 ++- lib/chibi/ast.c | 7 +++++ lib/chibi/ast.scm | 4 +++ lib/chibi/ast.sld | 1 + lib/chibi/repl.scm | 72 +++++++++++++++++++------------------------- lib/chibi/repl.sld | 7 ++++- sexp.c | 1 + vm.c | 6 ++++ 8 files changed, 59 insertions(+), 43 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 2790bb07..ef4309da 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -568,7 +568,7 @@ struct sexp_struct { unsigned char* ip; struct timeval tval; #endif - char tailp, tracep, timeoutp, waitp, errorp; + char tailp, tracep, timeoutp, waitp, errorp, interruptp; sexp_uint_t last_fp; sexp_uint_t gc_count; #if SEXP_USE_TIME_GC @@ -1373,6 +1373,7 @@ enum sexp_uniform_vector_type { #define sexp_context_result(x) (sexp_field(x, context, SEXP_CONTEXT, result)) #define sexp_context_errorp(x) (sexp_field(x, context, SEXP_CONTEXT, errorp)) +#define sexp_context_interruptp(x) (sexp_field(x, context, SEXP_CONTEXT, interruptp)) /* during compilation, sexp_context_specific is set to a vector */ /* containing the following elements: */ @@ -1509,6 +1510,7 @@ enum sexp_context_globals { SEXP_G_OOM_ERROR, /* out of memory exception object */ SEXP_G_OOS_ERROR, /* out of stack exception object */ SEXP_G_ABI_ERROR, /* incompatible ABI loading library */ + SEXP_G_INTERRUPT_ERROR, /* C-c in the repl */ SEXP_G_OPTIMIZATIONS, SEXP_G_SIGNAL_HANDLERS, SEXP_G_META_ENV, diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index 13d776ed..fa40f323 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -488,6 +488,12 @@ sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new_val) { } #endif +sexp sexp_thread_interrupt (sexp ctx, sexp self, sexp_sint_t n, sexp thread) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + sexp_context_interruptp(thread) = 1; + return sexp_make_boolean(ctx == thread); +} + sexp sexp_thread_list (sexp ctx, sexp self, sexp_sint_t n) { sexp_gc_var1(res); sexp_gc_preserve1(ctx, res); @@ -738,6 +744,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char #if SEXP_USE_GREEN_THREADS sexp_define_foreign(ctx, env, "%set-atomic!", 1, sexp_set_atomic); #endif + sexp_define_foreign(ctx, env, "%thread-interrupt!", 1, sexp_thread_interrupt); sexp_define_foreign(ctx, env, "thread-list", 0, sexp_thread_list); sexp_define_foreign_opt(ctx, env, "string-contains", 3, sexp_string_contains, sexp_make_string_cursor(0)); sexp_define_foreign(ctx, env, "string-cursor-copy!", 5, sexp_string_cursor_copy); diff --git a/lib/chibi/ast.scm b/lib/chibi/ast.scm index a9e0c80b..e57e1340 100644 --- a/lib/chibi/ast.scm +++ b/lib/chibi/ast.scm @@ -408,3 +408,7 @@ (else (define-syntax atomically (syntax-rules () ((atomically . body) (begin . body)))))) + +(define (thread-interrupt! thread) + (if (%thread-interrupt! thread) + (yield!))) diff --git a/lib/chibi/ast.sld b/lib/chibi/ast.sld index 2856f656..f23ed0a5 100644 --- a/lib/chibi/ast.sld +++ b/lib/chibi/ast.sld @@ -40,6 +40,7 @@ string-contains string-cursor-copy! errno integer->error-string flatten-dot update-free-vars! setenv unsetenv safe-setenv immutable? make-immutable! + thread-interrupt! chibi-version) (import (chibi)) (include-shared "ast") diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm index 82877800..fad9b498 100644 --- a/lib/chibi/repl.scm +++ b/lib/chibi/repl.scm @@ -401,48 +401,38 @@ (else (push-history-value! value)))) (define (repl/eval rp expr-list) - (let ((out (repl-out rp))) - (protect (exn (else (print-exception exn out))) - (let ((thread - (make-thread - (lambda () - ;; The inner protect in the child thread catches errors - ;; from eval. - (protect (exn - (else - (print-exception exn out) - (repl-advise-exception exn (current-error-port)))) + (let ((thread (current-thread)) + (out (repl-out rp))) + (with-signal-handler + signal/interrupt + (lambda (n) (thread-interrupt! thread)) + (lambda () + (protect (exn + (else + (print-exception exn out) + (repl-advise-exception exn (current-error-port)))) + (for-each + (lambda (expr) + (call-with-values + (lambda () + (if (or (identifier? expr) + (pair? expr) + (null? expr)) + (eval expr (repl-env rp)) + expr)) + (lambda res-list + (cond + ((not (or (null? res-list) + (equal? res-list (list (if #f #f))))) + (push-history-value-maybe! res-list) + (write/ss (car res-list) out) (for-each - (lambda (expr) - (call-with-values - (lambda () - (if (or (identifier? expr) - (pair? expr) - (null? expr)) - (eval expr (repl-env rp)) - expr)) - (lambda res-list - (cond - ((not (or (null? res-list) - (equal? res-list (list (if #f #f))))) - (push-history-value-maybe! res-list) - (write/ss (car res-list) out) - (for-each - (lambda (res) - (write-char #\space out) - (write/ss res out)) - (cdr res-list)) - (newline out)))))) - expr-list)))))) - ;; 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 "\nInterrupt\n" out) - (thread-terminate! thread)) - (lambda () (thread-join! (thread-start! thread)))))))) + (lambda (res) + (write-char #\space out) + (write/ss res out)) + (cdr res-list)) + (newline out)))))) + expr-list)))))) (define (repl/eval-string rp str) (repl/eval diff --git a/lib/chibi/repl.sld b/lib/chibi/repl.sld index dd2e03d3..ae504cba 100644 --- a/lib/chibi/repl.sld +++ b/lib/chibi/repl.sld @@ -5,5 +5,10 @@ (chibi ast) (chibi modules) (chibi doc) (chibi string) (chibi io) (chibi optional) (chibi process) (chibi term edit-line) - (srfi 1) (srfi 9) (srfi 18) (srfi 38) (srfi 95) (srfi 98)) + (srfi 1) + (srfi 9) + (only (srfi 18) current-thread) + (srfi 38) + (srfi 95) + (srfi 98)) (include "repl.scm")) diff --git a/sexp.c b/sexp.c index 891a3ca6..4ee1e543 100644 --- a/sexp.c +++ b/sexp.c @@ -549,6 +549,7 @@ void sexp_init_context_globals (sexp ctx) { sexp_global(ctx, SEXP_G_OOM_ERROR) = sexp_user_exception(ctx, SEXP_FALSE, "out of memory", SEXP_NULL); sexp_global(ctx, SEXP_G_OOS_ERROR) = sexp_user_exception(ctx, SEXP_FALSE, "out of stack space", SEXP_NULL); sexp_global(ctx, SEXP_G_ABI_ERROR) = sexp_user_exception(ctx, SEXP_FALSE, "incompatible ABI", SEXP_NULL); + sexp_global(ctx, SEXP_G_INTERRUPT_ERROR) = sexp_user_exception(ctx, SEXP_FALSE, "interrupt", SEXP_NULL); sexp_global(ctx, SEXP_G_QUOTE_SYMBOL) = sexp_intern(ctx, "quote", -1); sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL) = sexp_intern(ctx, "quasiquote", -1); sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL) = sexp_intern(ctx, "unquote", -1); diff --git a/vm.c b/vm.c index 7c807464..1fbb89b4 100644 --- a/vm.c +++ b/vm.c @@ -1031,6 +1031,12 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { loop: #if SEXP_USE_GREEN_THREADS if (--fuel <= 0) { + if (sexp_context_interruptp(ctx)) { + fuel = sexp_context_refuel(ctx); + sexp_context_interruptp(ctx) = 0; + _ARG1 = sexp_global(ctx, SEXP_G_INTERRUPT_ERROR); + goto call_error_handler; + } tmp1 = sexp_global(ctx, SEXP_G_THREADS_SCHEDULER); if (sexp_applicablep(tmp1) && sexp_not(sexp_global(ctx, SEXP_G_ATOMIC_P))) { /* save thread */