Changeset 18789 in project


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

Location:
release/4/pool/trunk
Files:
3 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)
  • release/4/pool/trunk/pool.setup

    r18621 r18789  
    55 'pool
    66 '("pool.so" "pool.import.so")
    7  `((version "0.1")))
     7 `((version "0.2")))
  • release/4/pool/trunk/tests/run.scm

    r18621 r18789  
    2121
    2222
    23 (test 'foo (call-with-value-from-pool pool
    24              (lambda (v)
    25                (thread-join! (call-with-value-from-pool-in-thread pool
    26                                (lambda (v)
    27                                  (thread-join! (call-with-value-from-pool-in-thread pool
    28                                                  (lambda (v)
    29                                                    (thread-join! (call-with-value-from-pool-in-thread pool identity)))))))))))
     23(test "returning false from the proc" #f (call-with-value-from-pool pool (constantly #f)))
     24
     25(test-error "deadlock"
     26            (let ((pool (make-pool '(a))))
     27              (call-with-value-from-pool pool
     28                (lambda (v)
     29                  (thread-join!
     30                   (call-with-value-from-pool-in-thread pool identity))))))
     31(let* ((value 0)
     32       (pool (make-pool '(1))))
     33  (for-each (lambda (i)
     34              (call-with-value-from-pool-in-thread pool
     35                (lambda (v)
     36                  (set! value (add1 value)))))
     37            (list-tabulate 10 (constantly 1)))
     38
     39  (let loop ((threads (##sys#all-threads)))
     40    (unless (null? threads)
     41      (thread-join! (car threads))
     42      (loop (##sys#all-threads))))
     43
     44  (test 10 value))
     45
     46
     47;; this one is left to fail - it needs dynamic-wind to be fixed but I couldn't make it work so far
     48(let ((jump #f)
     49      (done #f))
     50
     51  (call-with-value-from-pool pool
     52    (lambda (v)
     53      (call/cc (lambda (c)
     54                 (set! jump c)))
     55
     56      (when done
     57        (test "value is still locked" 'foo (alist-ref (current-thread) (pool-locked-values pool))))))
     58 
     59  (unless done
     60    (set! done #t)
     61    (call-with-value-from-pool-in-thread pool (lambda (v) (thread-suspend! (current-thread))))
     62    (jump #t)))
Note: See TracChangeset for help on using the changeset viewer.