Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding thread-interrupt! so that (chibi repl) can preserve continuations (issue #686)

Browse source
This commit is contained in:
Alex Shinn 2020-08-25 14:09:29 +09:00
parent e307c872bf
commit 60c4007e6f
8 changed files with 59 additions and 43 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
include/chibi/sexp.h
View file

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

7
lib/chibi/ast.c
View file

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

4
lib/chibi/ast.scm
View file

@ -408,3 +408,7 @@
(else
(define-syntax atomically
(syntax-rules () ((atomically . body) (begin . body))))))
(define (thread-interrupt! thread)
(if (%thread-interrupt! thread)
(yield!)))

1
lib/chibi/ast.sld
View file

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

72
lib/chibi/repl.scm
View file

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

7
lib/chibi/repl.sld
View file

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

1
sexp.c
View file

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

6
vm.c
View file

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