cbaines/guile-prometheus
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Wrap use of mutexes with call-with-blocked-asyncs

Browse source 
As this will hopefully avoid problems with mutexes when using fibers.
This commit is contained in:
Christopher Baines 2023-11-12 13:37:24 +00:00
parent 35dc26c0ea
commit fbd64347fb
1 changed files with 70 additions and 60 deletions
Download patch file Download diff file Expand all files Collapse all files

130
prometheus.scm
View file

@ -294,12 +294,14 @@ values are the values."
(canonicalise-label-values label-values)) (canonicalise-label-values label-values))
(hash (hash
(metric-values metric))) (metric-values metric)))
(with-mutex (metric-mutex metric) (call-with-blocked-asyncs
(hash-set! hash (lambda ()
canonical-labels (with-mutex (metric-mutex metric)
(+ by (hash-set! hash
(or (hash-ref hash canonical-labels) canonical-labels
0)))))) (+ by
(or (hash-ref hash canonical-labels)
0))))))))
(define* (metric-decrement metric (define* (metric-decrement metric
#:key #:key
@ -320,12 +322,14 @@ values are the values."
(canonicalise-label-values label-values)) (canonicalise-label-values label-values))
(hash (hash
(metric-values metric))) (metric-values metric)))
(with-mutex (metric-mutex metric) (call-with-blocked-asyncs
(hash-set! hash (lambda ()
canonical-labels (with-mutex (metric-mutex metric)
(+ (* -1 by) (hash-set! hash
(or (hash-ref hash canonical-labels) canonical-labels
0)))))) (+ (* -1 by)
(or (hash-ref hash canonical-labels)
0))))))))
(define* (metric-set metric value (define* (metric-set metric value
#:key (label-values '())) #:key (label-values '()))
@ -340,10 +344,12 @@ values are the values."
'(gauge)) '(gauge))
(error "can only set gauge metrics")) (error "can only set gauge metrics"))
(with-mutex (metric-mutex metric) (call-with-blocked-asyncs
(hash-set! (metric-values metric) (lambda ()
(canonicalise-label-values label-values) (with-mutex (metric-mutex metric)
value))) (hash-set! (metric-values metric)
(canonicalise-label-values label-values)
value)))))
(define* (metric-observe metric value (define* (metric-observe metric value
#:key (label-values '())) #:key (label-values '()))
@ -363,39 +369,41 @@ values are the values."
(hash (hash
(metric-values metric))) (metric-values metric)))
(with-mutex (metric-mutex metric) (call-with-blocked-asyncs
(let* ((buckets (lambda ()
(histogram-metric-type-buckets (metric-type metric))) (with-mutex (metric-mutex metric)
(histogram-values-record (let* ((buckets
(or (hash-ref hash canonical-labels) (histogram-metric-type-buckets (metric-type metric)))
(let ((new-record (make-histogram-values (make-vector (histogram-values-record
(length buckets) (or (hash-ref hash canonical-labels)
0) (let ((new-record (make-histogram-values (make-vector
0 (length buckets)
0))) 0)
(hash-set! hash canonical-labels new-record) 0
new-record)))) 0)))
(hash-set! hash canonical-labels new-record)
new-record))))
(set-histogram-values-sum! histogram-values-record (set-histogram-values-sum! histogram-values-record
(+ value (+ value
(histogram-values-sum (histogram-values-sum
histogram-values-record))) histogram-values-record)))
(set-histogram-values-count! histogram-values-record (set-histogram-values-count! histogram-values-record
(+ 1 (+ 1
(histogram-values-count (histogram-values-count
histogram-values-record))) histogram-values-record)))
(let ((bucket-values-vector (histogram-values-buckets (let ((bucket-values-vector (histogram-values-buckets
histogram-values-record))) histogram-values-record)))
(for-each (for-each
(lambda (index bucket-upper-limit) (lambda (index bucket-upper-limit)
(when (<= value bucket-upper-limit) (when (<= value bucket-upper-limit)
(vector-set! bucket-values-vector (vector-set! bucket-values-vector
index index
(+ 1 (+ 1
(vector-ref bucket-values-vector (vector-ref bucket-values-vector
index))))) index)))))
(iota (length buckets)) (iota (length buckets))
buckets)))))) buckets))))))))
(define* (call-with-duration-metric registry metric-name thunk (define* (call-with-duration-metric registry metric-name thunk
#:key #:key
@ -413,18 +421,20 @@ The metric with the name @var{metric-name} is fetched from the
" "
(let* ((metric (let* ((metric
(or (metrics-registry-fetch-metric registry metric-name) (or (metrics-registry-fetch-metric registry metric-name)
(monitor (call-with-blocked-asyncs
;; Check once more in case another thread has created (lambda ()
;; the metric while this thread was waiting for the (monitor
;; mutex ;; Check once more in case another thread has created
(or (metrics-registry-fetch-metric registry metric-name) ;; the metric while this thread was waiting for the
(make-histogram-metric ;; mutex
registry (or (metrics-registry-fetch-metric registry metric-name)
metric-name (make-histogram-metric
#:buckets buckets registry
#:docstring docstring metric-name
#:labels labels #:buckets buckets
#:label-preset-values label-preset-values))))) #:docstring docstring
#:labels labels
#:label-preset-values label-preset-values)))))))
(start-time (get-internal-real-time))) (start-time (get-internal-real-time)))
(call-with-values (call-with-values
thunk thunk