Making the dynamic-wind state thread-specific.

eval.c

@@ -442,7 +442,10 @@ sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size, s
   if (ctx) {
     sexp_context_params(res) = sexp_context_params(ctx);
     sexp_context_tracep(res) = sexp_context_tracep(ctx);
+    sexp_context_dk(res) = sexp_context_dk(ctx);
     sexp_gc_release1(ctx);
+  } else {
+    sexp_context_dk(res) = sexp_list1(res, SEXP_FALSE);
   }
   return res;
 }
@@ -1866,6 +1869,17 @@ sexp sexp_parameter_ref (sexp ctx, sexp param) {
     ? sexp_cdr(sexp_opcode_data(param)) : SEXP_FALSE;
 }
 
+#if SEXP_USE_GREEN_THREADS
+sexp sexp_dk (sexp ctx, sexp self, sexp_uint_t n, sexp val) {
+  if (sexp_not(val)) {
+    return sexp_context_dk(ctx) ? sexp_context_dk(ctx) : SEXP_FALSE;
+  } else {
+    sexp_context_dk(ctx) = val;
+    return SEXP_VOID;
+  }
+}
+#endif
+
 void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value) {
   sexp param = sexp_env_ref(env, name, SEXP_FALSE);
   if (sexp_opcodep(param)) {

include/chibi/eval.h

@@ -87,6 +87,9 @@ SEXP_API sexp sexp_make_lit (sexp ctx, sexp value);
 SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1);
 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);
+#endif
 
 #if SEXP_USE_NATIVE_X86
 SEXP_API sexp sexp_write_char_op(sexp ctx, sexp self, sexp_sint_t n, sexp ch, sexp out);

include/chibi/sexp.h

@@ -389,7 +389,7 @@ struct sexp_struct {
       char tailp, tracep, timeoutp, waitp;
       sexp_uint_t pos, depth, last_fp;
       sexp bc, lambda, stack, env, fv, parent, child,
-        globals, params, proc, name, specific, event;
+        globals, dk, params, proc, name, specific, event;
 #if SEXP_USE_DL
       sexp dl;
 #endif
@@ -921,6 +921,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_context_tailp(x)    (sexp_field(x, context, SEXP_CONTEXT, tailp))
 #define sexp_context_tracep(x)   (sexp_field(x, context, SEXP_CONTEXT, tracep))
 #define sexp_context_globals(x)  (sexp_field(x, context, SEXP_CONTEXT, globals))
+#define sexp_context_dk(x)       (sexp_field(x, context, SEXP_CONTEXT, dk))
 #define sexp_context_params(x)   (sexp_field(x, context, SEXP_CONTEXT, params))
 #define sexp_context_last_fp(x)  (sexp_field(x, context, SEXP_CONTEXT, last_fp))
 #define sexp_context_refuel(x)   (sexp_field(x, context, SEXP_CONTEXT, refuel))
@@ -1074,7 +1075,6 @@ enum sexp_context_globals {
   SEXP_G_THREADS_FRONT,
   SEXP_G_THREADS_BACK,
   SEXP_G_THREADS_PAUSED,
-  SEXP_G_THREADS_LOCAL,
   SEXP_G_THREADS_SIGNALS,
   SEXP_G_THREADS_SIGNAL_RUNNER,
   SEXP_G_THREADS_POLL_FDS,

lib/init-7.scm

@@ -110,6 +110,9 @@
       (if (pair? ls) (every1 pred ls) #t)
       (not (apply any (lambda (x) (not (pred x))) ls lol))))
 
+(define (error msg . args)
+  (raise (make-exception 'user msg args #f #f)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; syntax
 
@@ -543,30 +546,59 @@
         (apply consumer (cdr res))
         (consumer res))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; SRFI-0
+
+(define-syntax cond-expand
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (define (check x)
+       (if (pair? x)
+           (case (car x)
+             ((and) (every check (cdr x)))
+             ((or) (any check (cdr x)))
+             ((not) (not (check (cadr x))))
+             (else (error "cond-expand: bad feature" x)))
+           (memq (identifier->symbol x) *features*)))
+     (let expand ((ls (cdr expr)))
+       (cond ((null? ls) (error "cond-expand: no expansions" expr))
+             ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls)))
+             ((eq? 'else (identifier->symbol (caar ls)))
+              (if (pair? (cdr ls))
+                  (error "cond-expand: else in non-final position")
+                  `(,(rename 'begin) ,@(cdar ls))))
+             ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls)))
+             (else (expand (cdr ls))))))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; dynamic-wind
 
-(define *dk* (list #f))
+(cond-expand
+ (threads)
+ (else
+  (define %dk
+    (let ((dk (list #f)))
+      (lambda o (if (pair? o) (set! dk (car o)) dk))))))
 
 (define (dynamic-wind before thunk after)
-  (let ((dk *dk*))
+  (let ((dk (%dk)))
     (set-dk! (cons (cons before after) dk))
     (let ((res (thunk))) (set-dk! dk) res)))
 
 (define (set-dk! dk)
-  (if (not (eq? dk *dk*))
+  (if (not (eq? dk (%dk)))
       (begin
         (set-dk! (cdr dk))
         (let ((before (car (car dk))) (dk dk))
-          (set-car! *dk* (cons (cdr (car dk)) before))
+          (set-car! (%dk) (cons (cdr (car dk)) before))
-          (set-cdr! *dk* dk)
+          (set-cdr! (%dk) dk)
           (set-car! dk #f)
           (set-cdr! dk '())
-          (set! *dk* dk)
+          (%dk dk)
           (before)))))
 
 (define (call-with-current-continuation proc)
-  (let ((dk *dk*))
+  (let ((dk (%dk)))
     (%call/cc (lambda (k) (proc (lambda x (set-dk! dk) (k (%values x))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -805,9 +837,6 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; exceptions
 
-(define (error msg . args)
-  (raise (make-exception 'user msg args #f #f)))
-
 (define *continuable* (list 'continuable))
 
 (define (raise-continuable exn)
@@ -846,30 +875,6 @@
     ((guard (var (test . handler) ...) body ...)
      (guard (var (test . handler) ... (else (raise var))) body ...))))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; SRFI-0
-
-(define-syntax cond-expand
-  (er-macro-transformer
-   (lambda (expr rename compare)
-     (define (check x)
-       (if (pair? x)
-           (case (car x)
-             ((and) (every check (cdr x)))
-             ((or) (any check (cdr x)))
-             ((not) (not (check (cadr x))))
-             (else (error "cond-expand: bad feature" x)))
-           (memq (identifier->symbol x) *features*)))
-     (let expand ((ls (cdr expr)))
-       (cond ((null? ls) (error "cond-expand: no expansions" expr))
-             ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls)))
-             ((eq? 'else (identifier->symbol (caar ls)))
-              (if (pair? (cdr ls))
-                  (error "cond-expand: else in non-final position")
-                  `(,(rename 'begin) ,@(cdar ls))))
-             ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls)))
-             (else (expand (cdr ls))))))))
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; promises
 

lib/srfi/18/threads.c

@@ -71,8 +71,10 @@ sexp sexp_current_thread (sexp ctx, sexp self, sexp_sint_t n) {
 }
 
 sexp sexp_make_thread (sexp ctx, sexp self, sexp_sint_t n, sexp thunk, sexp name) {
-  sexp res, *stack;
+  sexp *stack;
+  sexp_gc_var1(res);
   sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, thunk);
+  sexp_gc_preserve1(ctx, res);
   res = sexp_make_eval_context(ctx, SEXP_FALSE, sexp_context_env(ctx), 0, 0);
   sexp_context_name(res) = name;
   sexp_context_proc(res) = thunk;
@@ -82,6 +84,8 @@ sexp sexp_make_thread (sexp ctx, sexp self, sexp_sint_t n, sexp thunk, sexp name
   stack[2] = sexp_global(ctx, SEXP_G_FINAL_RESUMER);
   sexp_context_top(res) = 4;
   sexp_context_last_fp(res) = 0;
+  sexp_context_dk(res) = sexp_list1(ctx, SEXP_FALSE);
+  sexp_gc_release1(ctx);
   return res;
 }
 

opcodes.c

@@ -222,6 +222,7 @@ _FN2(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_ENV), "load-module-file", 0, sexp_load_
 _FN2(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_BOOLEAN), "add-module-directory", 0, sexp_add_module_directory_op),
 #endif
 #if SEXP_USE_GREEN_THREADS
+_FN1OPT(_I(SEXP_OBJECT), _I(SEXP_OBJECT), "%dk", SEXP_FALSE, sexp_dk),
 _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

sexp.c

@@ -184,7 +184,7 @@ static struct sexp_type_struct _sexp_type_specs[] = {
   {SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Sequence", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL},
   {SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Literal", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL},
   {SEXP_STACK, sexp_offsetof(stack, data), 1, 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), 0, 0, 0, 0, 0, 0, (sexp)"Stack", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
-  {SEXP_CONTEXT, sexp_offsetof(context, bc), 13+SEXP_USE_DL, 13+SEXP_USE_DL, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Context", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+  {SEXP_CONTEXT, sexp_offsetof(context, bc), 14+SEXP_USE_DL, 14+SEXP_USE_DL, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Context", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
   {SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Cpointer", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
 #if SEXP_USE_AUTO_FORCE
   {SEXP_PROMISE, sexp_offsetof(promise, thunk), 2, 2, 0, 0, sexp_sizeof(promise), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Promise", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
@@ -441,6 +441,7 @@ sexp sexp_make_context (sexp ctx, size_t size, size_t max_size) {
 #endif
   if (ctx) {
     sexp_context_globals(res) = sexp_context_globals(ctx);
+    sexp_context_dk(res) = sexp_context_dk(ctx);
     sexp_gc_release1(ctx);
   } else {
     sexp_init_context_globals(res);