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

Using non-mutating tree of dynamic-wind state for thread safety.

Browse source
This commit is contained in:
Alex Shinn 2013-04-07 23:59:41 +09:00
parent d76c4e47c9
commit 2e63b2be00
2 changed files with 52 additions and 29 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
eval.c
View file

@ -499,7 +499,9 @@ sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size, s
sexp_context_dk(res) = sexp_context_dk(ctx);
sexp_gc_release1(ctx);
} else {
sexp_context_dk(res) = sexp_list1(res, SEXP_FALSE);
/* TODO: make the root a global (with friendly error in/out) */
sexp_context_dk(res) = sexp_make_vector(res, SEXP_FOUR, SEXP_FALSE);
sexp_vector_set(sexp_context_dk(res), SEXP_ZERO, SEXP_ZERO);
}
}
return res;

71
lib/init-7.scm
View file

@ -579,36 +579,60 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; dynamic-wind
(define make-point vector)
(define (point-depth point) (vector-ref point 0))
(define (point-in point) (vector-ref point 1))
(define (point-out point) (vector-ref point 2))
(define (point-parent point) (vector-ref point 3))
(define root-point ; Shared among all state spaces
(make-point 0
(lambda () (error "winding in to root!"))
(lambda () (error "winding out of root!"))
#f))
(cond-expand
(threads)
(else
(define %dk
(let ((dk (list #f)))
(let ((dk root-point))
(lambda o (if (pair? o) (set! dk (car o)) dk))))))
(define (dynamic-wind before thunk after)
(let ((dk (%dk)))
(set-dk! (cons (cons before after) dk))
(let ((res (thunk))) (set-dk! dk) res)))
(%dk root-point)
;; TODO: Implement a non-mutating tree oriented stack so we don't need
;; to reset the stack in child threads.
(define (set-dk! new-dk)
(if (not (eq? new-dk (%dk)))
(begin
(set-dk! (cdr new-dk))
(let ((before (car (car new-dk)))
(old-dk (%dk)))
(set-car! old-dk (cons (cdr (car new-dk)) before))
(set-cdr! old-dk new-dk)
(set-car! new-dk #f)
(set-cdr! new-dk '())
(%dk new-dk)
(before)))))
(define (dynamic-wind in body out)
(in)
(let ((here (%dk)))
(%dk (make-point (+ (point-depth here) 1)
in
out
here))
(let ((res (body)))
(%dk here)
(out)
res)))
(define (travel-to-point! here target)
(cond
((eq? here target)
'done)
((< (point-depth here) (point-depth target))
(travel-to-point! here (point-parent target))
((point-in target)))
(else
((point-out here))
(travel-to-point! (point-parent here) target))))
(define (continuation->procedure cont point)
(lambda res
(travel-to-point! (%dk) point)
(%dk point)
(cont (%values res))))
(define (call-with-current-continuation proc)
(let ((dk (%dk)))
(%call/cc (lambda (k) (proc (lambda x (set-dk! dk) (k (%values x))))))))
(%call/cc
(lambda (cont)
(proc (continuation->procedure cont (%dk))))))
(define (with-input-from-file file thunk)
(let ((old-in (current-input-port))
@ -932,13 +956,10 @@
(lambda (handler-k)
(let* ((var condition) ; clauses may set! var
(res
(with-exception-handler
orig-handler
(lambda ()
(guard-aux
(handler-k (lambda ()
(raise-continuable condition)))
clause ...)))))
clause ...)))
(guard-k (lambda () res)))))))
(lambda ()
(let ((res (begin e1 e2 ...)))