diff --git a/eval.c b/eval.c index 0d73ee90..ee9593af 100644 --- a/eval.c +++ b/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)) { diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 80251fb7..158c1090 100644 --- a/include/chibi/eval.h +++ b/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); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index bd2b8056..22f33c6a 100755 --- a/include/chibi/sexp.h +++ b/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, diff --git a/lib/init-7.scm b/lib/init-7.scm index b95ada8c..47a6d472 100644 --- a/lib/init-7.scm +++ b/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-cdr! *dk* dk) + (set-car! (%dk) (cons (cdr (car dk)) before)) + (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 diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c index d2b235d1..938983db 100644 --- a/lib/srfi/18/threads.c +++ b/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; } diff --git a/opcodes.c b/opcodes.c index 35861f38..3030a99c 100644 --- a/opcodes.c +++ b/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 diff --git a/sexp.c b/sexp.c index 09dd7bb2..4cd9a989 100644 --- a/sexp.c +++ b/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);