mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-08 05:27:35 +02:00
Using non-mutating tree of dynamic-wind state for thread safety.
This commit is contained in:
parent
d76c4e47c9
commit
2e63b2be00
2 changed files with 52 additions and 29 deletions
4
eval.c
4
eval.c
|
@ -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_context_dk(res) = sexp_context_dk(ctx);
|
||||||
sexp_gc_release1(ctx);
|
sexp_gc_release1(ctx);
|
||||||
} else {
|
} 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;
|
return res;
|
||||||
|
|
|
@ -579,36 +579,60 @@
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; dynamic-wind
|
;; 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
|
(cond-expand
|
||||||
(threads)
|
(threads)
|
||||||
(else
|
(else
|
||||||
(define %dk
|
(define %dk
|
||||||
(let ((dk (list #f)))
|
(let ((dk root-point))
|
||||||
(lambda o (if (pair? o) (set! dk (car o)) dk))))))
|
(lambda o (if (pair? o) (set! dk (car o)) dk))))))
|
||||||
|
|
||||||
(define (dynamic-wind before thunk after)
|
(%dk root-point)
|
||||||
(let ((dk (%dk)))
|
|
||||||
(set-dk! (cons (cons before after) dk))
|
|
||||||
(let ((res (thunk))) (set-dk! dk) res)))
|
|
||||||
|
|
||||||
;; TODO: Implement a non-mutating tree oriented stack so we don't need
|
(define (dynamic-wind in body out)
|
||||||
;; to reset the stack in child threads.
|
(in)
|
||||||
(define (set-dk! new-dk)
|
(let ((here (%dk)))
|
||||||
(if (not (eq? new-dk (%dk)))
|
(%dk (make-point (+ (point-depth here) 1)
|
||||||
(begin
|
in
|
||||||
(set-dk! (cdr new-dk))
|
out
|
||||||
(let ((before (car (car new-dk)))
|
here))
|
||||||
(old-dk (%dk)))
|
(let ((res (body)))
|
||||||
(set-car! old-dk (cons (cdr (car new-dk)) before))
|
(%dk here)
|
||||||
(set-cdr! old-dk new-dk)
|
(out)
|
||||||
(set-car! new-dk #f)
|
res)))
|
||||||
(set-cdr! new-dk '())
|
|
||||||
(%dk new-dk)
|
(define (travel-to-point! here target)
|
||||||
(before)))))
|
(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)
|
(define (call-with-current-continuation proc)
|
||||||
(let ((dk (%dk)))
|
(%call/cc
|
||||||
(%call/cc (lambda (k) (proc (lambda x (set-dk! dk) (k (%values x))))))))
|
(lambda (cont)
|
||||||
|
(proc (continuation->procedure cont (%dk))))))
|
||||||
|
|
||||||
(define (with-input-from-file file thunk)
|
(define (with-input-from-file file thunk)
|
||||||
(let ((old-in (current-input-port))
|
(let ((old-in (current-input-port))
|
||||||
|
@ -932,13 +956,10 @@
|
||||||
(lambda (handler-k)
|
(lambda (handler-k)
|
||||||
(let* ((var condition) ; clauses may set! var
|
(let* ((var condition) ; clauses may set! var
|
||||||
(res
|
(res
|
||||||
(with-exception-handler
|
(guard-aux
|
||||||
orig-handler
|
(handler-k (lambda ()
|
||||||
(lambda ()
|
(raise-continuable condition)))
|
||||||
(guard-aux
|
clause ...)))
|
||||||
(handler-k (lambda ()
|
|
||||||
(raise-continuable condition)))
|
|
||||||
clause ...)))))
|
|
||||||
(guard-k (lambda () res)))))))
|
(guard-k (lambda () res)))))))
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let ((res (begin e1 e2 ...)))
|
(let ((res (begin e1 e2 ...)))
|
||||||
|
|
Loading…
Add table
Reference in a new issue