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

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

pool: initial import

File size: 1.1 KB
Line 
1(module pool
2
3(make-pool call-with-value-from-pool call-with-value-from-pool-in-thread)
4
5(import chicken scheme extras)
6(use srfi-1 srfi-18)
7
8(define-record pool values)
9
10(let ((original-make-pool make-pool))
11  (set! make-pool
12        (lambda (values)
13          (original-make-pool (map (lambda (v)
14                                     (let ((m (make-mutex)))
15                                       (mutex-specific-set! m v)
16                                       m))
17                                   values)))))
18
19(define (current-thread-mutex? mutex)
20  (eq? (mutex-state mutex) (current-thread)))
21
22(define (call-with-value-from-pool pool proc)
23  (let ((call  (lambda ()
24                 (let ((value #f))
25                   (dynamic-wind
26                       (lambda () 
27                         (set! value 
28                               (find (lambda (v)
29                                       (or (current-thread-mutex? v)
30                                           (mutex-lock! v 0 (current-thread))))
31                                     (pool-values pool))))
32                       (lambda () (and value (proc (mutex-specific value))))
33                       (lambda () (when value (mutex-unlock! value))))))))
34
35    (or (call) (let loop ()
36                 (thread-sleep! 0.5)
37                 (or (call) (loop))))))
38
39(define (call-with-value-from-pool-in-thread pool proc)
40  (thread-start! (lambda ()
41                   (call-with-value-from-pool pool proc))))
42
43)
Note: See TracBrowser for help on using the repository browser.