source: project/release/4/pool/trunk/pool.scm @ 18789

Last change on this file since 18789 was 18789, checked in by Moritz Heidkamp, 10 years ago

pool: use a condition variable instead of sleep intervals to signal when locks are freed to waiting threads and bump version to 0.2

File size: 1.7 KB
Line 
1(module pool
2
3(make-pool pool-values pool-locked-values call-with-value-from-pool call-with-value-from-pool-in-thread)
4
5(import chicken scheme extras data-structures)
6(use srfi-1 srfi-18)
7
8(define-record pool values locked-values mutex condition)
9
10(let ((original-make-pool make-pool))
11  (set! make-pool
12        (lambda (values)
13          (original-make-pool values
14                              '()
15                              (make-mutex)
16                              (make-condition-variable)))))
17
18(define (pool-value-lock! pool)
19  (and (pair? (pool-values pool))
20       (let ((value (car (pool-values pool))))
21         (pool-values-set! pool (cdr (pool-values pool)))
22         (pool-locked-values-set! pool (alist-cons (current-thread) 
23                                                   value
24                                                   (pool-locked-values pool)))
25         value)))
26
27(define (pool-value-unlock! pool value)
28  (pool-locked-values-set! pool (alist-delete (current-thread) (pool-locked-values pool) eq?))
29  (pool-values-set! pool (cons value (pool-values pool))))
30
31(define (call-with-value-from-pool pool proc)
32  (let loop ()
33    (mutex-lock! (pool-mutex pool))
34               
35    (let* ((result #f)
36           (unlock #t)
37           (value (alist-ref (current-thread) (pool-locked-values pool) eq?))
38           (value (if value
39                      (begin (set! unlock #f) value)
40                      (pool-value-lock! pool))))
41                 
42      (if value
43          (begin
44            (mutex-unlock! (pool-mutex pool))
45            (let ((result (proc value)))
46              (when unlock
47                (mutex-lock! (pool-mutex pool))
48                (pool-value-unlock! pool value)
49                (condition-variable-signal! (pool-condition pool))
50                (mutex-unlock! (pool-mutex pool)))
51             
52              result))
53          (begin
54            (mutex-unlock! (pool-mutex pool) (pool-condition pool))
55            (loop))))))
56
57(define (call-with-value-from-pool-in-thread pool proc)
58  (thread-start! (lambda ()
59                   (call-with-value-from-pool pool proc))))
60
61)
Note: See TracBrowser for help on using the repository browser.