(module pool

(make-pool pool-values pool-locked-values call-with-value-from-pool call-with-value-from-pool-in-thread)

(import chicken scheme extras data-structures)
(use srfi-1 srfi-18)

(define-record pool values locked-values mutex condition)

(let ((original-make-pool make-pool))
  (set! make-pool
	(lambda (values)
	  (original-make-pool values
			      '()
			      (make-mutex)
			      (make-condition-variable)))))

(define (pool-value-lock! pool)
  (and (pair? (pool-values pool))
       (let ((value (car (pool-values pool))))
	 (pool-values-set! pool (cdr (pool-values pool)))
	 (pool-locked-values-set! pool (alist-cons (current-thread) 
						   value
						   (pool-locked-values pool)))
	 value)))

(define (pool-value-unlock! pool value)
  (pool-locked-values-set! pool (alist-delete (current-thread) (pool-locked-values pool) eq?))
  (pool-values-set! pool (cons value (pool-values pool))))

(define (call-with-value-from-pool pool proc)
  (let loop ()
    (mutex-lock! (pool-mutex pool))
		
    (let* ((unlock #t)
	   (value (alist-ref (current-thread) (pool-locked-values pool) eq?))
	   (value (if value
		      (begin (set! unlock #f) value)
		      (pool-value-lock! pool))))
		  
      (if value
	  (begin
	    (mutex-unlock! (pool-mutex pool))
	    (let ((result (proc value)))
	      (when unlock
		(mutex-lock! (pool-mutex pool))
		(pool-value-unlock! pool value)
		(condition-variable-signal! (pool-condition pool))
		(mutex-unlock! (pool-mutex pool)))
	      
	      result))
	  (begin
	    (mutex-unlock! (pool-mutex pool) (pool-condition pool))
	    (loop))))))

(define (call-with-value-from-pool-in-thread pool proc)
  (thread-start! (lambda ()
		   (call-with-value-from-pool pool proc))))

)