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

Making the dynamic-wind state thread-specific.

Browse source
This commit is contained in:
Alex Shinn 2011-11-12 11:03:30 +09:00
parent 587273bee2
commit 2caa285a63
7 changed files with 66 additions and 38 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
eval.c
View file

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

3
include/chibi/eval.h
View file

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

4
include/chibi/sexp.h
View file

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

73
lib/init-7.scm
View file

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

6
lib/srfi/18/threads.c
View file

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

1
opcodes.c
View file

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

3
sexp.c
View file

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