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

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,

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

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!)))

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

lib/chibi/repl.scm

@@ -401,13 +401,12 @@
         (else (push-history-value! value))))
 
 (define (repl/eval rp expr-list)
-  (let ((out (repl-out rp)))
+  (let ((thread (current-thread))
-    (protect (exn (else (print-exception exn out)))
+        (out (repl-out rp)))
-      (let ((thread
+    (with-signal-handler
-             (make-thread
+     signal/interrupt
+     (lambda (n) (thread-interrupt! thread))
      (lambda ()
-                ;; The inner protect in the child thread catches errors
-                ;; from eval.
        (protect (exn
                  (else
                   (print-exception exn out)
@@ -434,15 +433,6 @@
                    (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))))))))
 
 (define (repl/eval-string rp str)
   (repl/eval

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

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

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