Implement lifetime support in the resource pool
This commit is contained in:
parent
e78e41b542
commit
1a476b5aa8
1 changed files with 108 additions and 40 deletions
|
|
@ -749,6 +749,7 @@
|
|||
(let loop ((resources '())
|
||||
(available '())
|
||||
(waiters (make-q))
|
||||
(resources-checkout-count '())
|
||||
(resources-last-used '()))
|
||||
|
||||
(match (get-message channel)
|
||||
|
|
@ -762,11 +763,13 @@
|
|||
(loop (cons resource resources)
|
||||
available
|
||||
waiters
|
||||
(cons 0 resources-checkout-count)
|
||||
(cons (get-internal-real-time)
|
||||
resources-last-used)))
|
||||
(loop resources
|
||||
available
|
||||
waiters
|
||||
resources-checkout-count
|
||||
resources-last-used)))
|
||||
|
||||
(let ((current-internal-time
|
||||
|
|
@ -777,6 +780,7 @@
|
|||
(loop (cons resource resources)
|
||||
(cons resource available)
|
||||
waiters
|
||||
(cons 0 resources-checkout-count)
|
||||
(cons current-internal-time
|
||||
resources-last-used)))
|
||||
((reply . timeout)
|
||||
|
|
@ -800,6 +804,7 @@
|
|||
(loop (cons resource resources)
|
||||
available
|
||||
waiters
|
||||
(cons 1 resources-checkout-count)
|
||||
(cons current-internal-time
|
||||
resources-last-used))))))))
|
||||
|
||||
|
|
@ -836,10 +841,12 @@
|
|||
(loop resources
|
||||
available
|
||||
waiters
|
||||
resources-checkout-count
|
||||
resources-last-used))
|
||||
(loop resources
|
||||
available
|
||||
(enq! waiters (cons reply timeout-time))
|
||||
resources-checkout-count
|
||||
resources-last-used))))
|
||||
|
||||
(if timeout-time
|
||||
|
|
@ -862,10 +869,21 @@
|
|||
(loop resources
|
||||
(cdr available)
|
||||
waiters
|
||||
(let ((resource-index
|
||||
(list-index (lambda (x)
|
||||
(eq? x (car available)))
|
||||
resources)))
|
||||
(list-set! resources-checkout-count
|
||||
resource-index
|
||||
(+ 1 (list-ref
|
||||
resources-checkout-count
|
||||
resource-index)))
|
||||
resources-checkout-count)
|
||||
resources-last-used))
|
||||
(loop resources
|
||||
available
|
||||
waiters
|
||||
resources-checkout-count
|
||||
resources-last-used)))
|
||||
(begin
|
||||
(put-message reply (cons 'success
|
||||
|
|
@ -874,6 +892,16 @@
|
|||
(loop resources
|
||||
(cdr available)
|
||||
waiters
|
||||
(let ((resource-index
|
||||
(list-index (lambda (x)
|
||||
(eq? x (car available)))
|
||||
resources)))
|
||||
(list-set! resources-checkout-count
|
||||
resource-index
|
||||
(+ 1 (list-ref
|
||||
resources-checkout-count
|
||||
resource-index)))
|
||||
resources-checkout-count)
|
||||
resources-last-used)))))
|
||||
|
||||
(((and (or 'return
|
||||
|
|
@ -892,46 +920,77 @@
|
|||
(list-index (lambda (x)
|
||||
(eq? x resource))
|
||||
resources)))
|
||||
(let waiter-loop ((waiter (safe-deq waiters)))
|
||||
(match waiter
|
||||
(#f
|
||||
(loop resources
|
||||
(cons resource available)
|
||||
waiters
|
||||
(begin
|
||||
(when (eq? return-type 'return)
|
||||
(list-set!
|
||||
resources-last-used
|
||||
resource-index
|
||||
current-internal-time))
|
||||
resources-last-used)))
|
||||
((reply . timeout)
|
||||
(if (and timeout
|
||||
(< timeout current-internal-time))
|
||||
(waiter-loop (safe-deq waiters))
|
||||
(if timeout
|
||||
(let ((reply-timeout
|
||||
(/ (- timeout
|
||||
current-internal-time)
|
||||
internal-time-units-per-second)))
|
||||
;; Don't sleep in this fiber, so spawn a
|
||||
;; new fiber to handle handing over the
|
||||
;; resource, and returning it if there's
|
||||
;; a timeout
|
||||
(spawn-fiber-for-checkout reply
|
||||
reply-timeout
|
||||
resource))
|
||||
(put-message reply (cons 'success
|
||||
resource))))
|
||||
(loop resources
|
||||
available
|
||||
waiters
|
||||
(begin
|
||||
(list-set!
|
||||
resources-last-used
|
||||
resource-index
|
||||
current-internal-time)
|
||||
resources-last-used)))))))
|
||||
(if (and lifetime
|
||||
(>= (list-ref resources-checkout-count
|
||||
resource-index)
|
||||
lifetime))
|
||||
(begin
|
||||
(spawn-fiber-to-destroy-resource resource)
|
||||
(loop resources
|
||||
available
|
||||
waiters
|
||||
resources-checkout-count
|
||||
resources-last-used))
|
||||
(let waiter-loop ((waiter (safe-deq waiters)))
|
||||
(match waiter
|
||||
(#f
|
||||
(loop resources
|
||||
(cons resource available)
|
||||
waiters
|
||||
(if (eq? 'return-failed-checkout
|
||||
return-type)
|
||||
(begin
|
||||
(list-set! resources-checkout-count
|
||||
resource-index
|
||||
(- (list-ref resources-checkout-count
|
||||
resource-index)
|
||||
1))
|
||||
resources-checkout-count)
|
||||
resources-checkout-count)
|
||||
(begin
|
||||
(when (eq? return-type 'return)
|
||||
(list-set!
|
||||
resources-last-used
|
||||
resource-index
|
||||
current-internal-time))
|
||||
resources-last-used)))
|
||||
((reply . timeout)
|
||||
(if (and timeout
|
||||
(< timeout current-internal-time))
|
||||
(waiter-loop (safe-deq waiters))
|
||||
(if timeout
|
||||
(let ((reply-timeout
|
||||
(/ (- timeout
|
||||
current-internal-time)
|
||||
internal-time-units-per-second)))
|
||||
;; Don't sleep in this fiber, so spawn a
|
||||
;; new fiber to handle handing over the
|
||||
;; resource, and returning it if there's
|
||||
;; a timeout
|
||||
(spawn-fiber-for-checkout reply
|
||||
reply-timeout
|
||||
resource))
|
||||
(put-message reply (cons 'success
|
||||
resource))))
|
||||
(loop resources
|
||||
available
|
||||
waiters
|
||||
(if (eq? 'return-failed-checkout
|
||||
return-type)
|
||||
(begin
|
||||
(list-set! resources-checkout-count
|
||||
resource-index
|
||||
(- (list-ref resources-checkout-count
|
||||
resource-index)
|
||||
1))
|
||||
resources-checkout-count)
|
||||
resources-checkout-count)
|
||||
(begin
|
||||
(list-set!
|
||||
resources-last-used
|
||||
resource-index
|
||||
current-internal-time)
|
||||
resources-last-used))))))))
|
||||
|
||||
(('remove resource)
|
||||
(let ((index
|
||||
|
|
@ -954,6 +1013,9 @@
|
|||
resources))
|
||||
available ; resource shouldn't be in this list
|
||||
waiters
|
||||
(remove-at-index!
|
||||
resources-checkout-count
|
||||
index)
|
||||
(remove-at-index!
|
||||
resources-last-used
|
||||
index))))
|
||||
|
|
@ -964,6 +1026,7 @@
|
|||
(loop resources
|
||||
available
|
||||
waiters
|
||||
resources-checkout-count
|
||||
resources-last-used))
|
||||
|
||||
(('list-resources reply)
|
||||
|
|
@ -974,6 +1037,7 @@
|
|||
(loop resources
|
||||
available
|
||||
waiters
|
||||
resources-checkout-count
|
||||
resources-last-used))
|
||||
|
||||
(('stats reply timeout-time)
|
||||
|
|
@ -981,6 +1045,7 @@
|
|||
`((resources . ,(length resources))
|
||||
(available . ,(length available))
|
||||
(waiters . ,(q-length waiters))
|
||||
(resources-checkout-count . ,resources-checkout-count)
|
||||
(checkout-failure-count . ,checkout-failure-count))))
|
||||
|
||||
(spawn-fiber
|
||||
|
|
@ -1000,6 +1065,7 @@
|
|||
(loop resources
|
||||
available
|
||||
waiters
|
||||
resources-checkout-count
|
||||
resources-last-used))
|
||||
|
||||
(('check-for-idle-resources)
|
||||
|
|
@ -1040,6 +1106,7 @@
|
|||
(loop resources
|
||||
(lset-difference eq? available resources-to-destroy)
|
||||
waiters
|
||||
resources-checkout-count
|
||||
resources-last-used))))
|
||||
|
||||
(('destroy)
|
||||
|
|
@ -1103,6 +1170,7 @@
|
|||
(loop resources
|
||||
available
|
||||
waiters
|
||||
resources-checkout-count
|
||||
resources-last-used)))))
|
||||
|
||||
(spawn-fiber
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue