(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)))
  (condition-variable-signal! (pool-condition pool)))


(define (call-with-value-from-pool pool proc)
  (let ((mutex (pool-mutex pool))
        (unlock-value? #t)
        (value #f))
    (dynamic-wind
        (lambda ()
          (unless (eq? (mutex-state mutex) (current-thread))
            (mutex-lock! mutex))
          (let ((v (alist-ref (current-thread) (pool-locked-values pool) eq?)))
            (if v
                (begin (set! unlock-value? #f) (set! value v))
                (set! value (pool-value-lock! pool)))))
        (lambda ()
          (if value
              (begin
                (mutex-unlock! mutex)
                (proc value))
              (begin
                (mutex-unlock! mutex (pool-condition pool))
                (call-with-value-from-pool pool proc))))
        (lambda ()
          (when unlock-value?
            (unless (eq? (mutex-state mutex) (current-thread))
              (mutex-lock! mutex))
            (pool-value-unlock! pool value))
          (when (eq? (mutex-state mutex) (current-thread))
            (mutex-unlock! mutex))))))

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

)