Changeset 18789 in project for release/4/pool/trunk/pool.scm


Ignore:
Timestamp:
07/10/10 23:48:03 (10 years ago)
Author:
Moritz Heidkamp
Message:

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:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/pool/trunk/pool.scm

    r18621 r18789  
    11(module pool
    22
    3 (make-pool call-with-value-from-pool call-with-value-from-pool-in-thread)
     3(make-pool pool-values pool-locked-values call-with-value-from-pool call-with-value-from-pool-in-thread)
    44
    5 (import chicken scheme extras)
     5(import chicken scheme extras data-structures)
    66(use srfi-1 srfi-18)
    77
    8 (define-record pool values)
     8(define-record pool values locked-values mutex condition)
    99
    1010(let ((original-make-pool make-pool))
    1111  (set! make-pool
    1212        (lambda (values)
    13           (original-make-pool (map (lambda (v)
    14                                      (let ((m (make-mutex)))
    15                                        (mutex-specific-set! m v)
    16                                        m))
    17                                    values)))))
     13          (original-make-pool values
     14                              '()
     15                              (make-mutex)
     16                              (make-condition-variable)))))
    1817
    19 (define (current-thread-mutex? mutex)
    20   (eq? (mutex-state mutex) (current-thread)))
     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))))
    2130
    2231(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))))))
     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))))))
    3856
    3957(define (call-with-value-from-pool-in-thread pool proc)
Note: See TracChangeset for help on using the changeset viewer.