cbaines pushed a commit to branch master
in repository data-service.
commit 3887435a7d9fa6594b1553fdb8e9d48cfa5af708
Author: Christopher Baines <[email protected]>
AuthorDate: Sat Aug 17 18:31:32 2024 +0100
Improve logging around use of inferiors
---
guix-data-service/jobs/load-new-guix-revision.scm | 71 +++++++++++++----------
1 file changed, 39 insertions(+), 32 deletions(-)
diff --git a/guix-data-service/jobs/load-new-guix-revision.scm
b/guix-data-service/jobs/load-new-guix-revision.scm
index 27393a9..e08e187 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -1787,23 +1787,31 @@ SELECT 1 FROM derivation_source_file_nars WHERE
derivation_source_file_id = $1"
(define (call-with-inferior proc)
(define (check-wal-size)
- (let loop ((wal-bytes
- (catch #t
- (lambda ()
- (stat:size (stat "/var/guix/db/db.sqlite-wal")))
- (lambda _ 0))))
- (when (> wal-bytes (* 256 (expt 2 20)))
- (let ((stats (resource-pool-stats inf-and-store-pool)))
- (simple-format
- #t "debug: guix-daemon WAL is large (~A), ~A inferiors, waiting\n"
- wal-bytes
- (assq-ref stats 'resources)))
-
- (sleep 30)
- (loop (catch #t
- (lambda ()
- (stat:size (stat "/var/guix/db/db.sqlite-wal")))
- (lambda _ 0))))))
+ (define threshold (* 256 (expt 2 20)))
+
+ (define (get-wal-bytes)
+ (catch #t
+ (lambda ()
+ (stat:size (stat "/var/guix/db/db.sqlite-wal")))
+ (lambda _ 0)))
+
+ (if (< (get-wal-bytes) threshold)
+ #t
+ (let loop ((wal-bytes (get-wal-bytes)))
+ (if (> wal-bytes threshold)
+ (let ((stats (resource-pool-stats inf-and-store-pool)))
+ (simple-format
+ #t "debug: guix-daemon WAL is large (~A), ~A inferiors,
waiting\n"
+ wal-bytes
+ (assq-ref stats 'resources))
+
+ (sleep 30)
+ (loop (get-wal-bytes)))
+ (begin
+ (simple-format
+ #t "debug: guix-daemon WAL now ~A bytes, continuing\n"
+ wal-bytes)
+ #t)))))
(let loop ()
(check-wal-size)
@@ -1821,6 +1829,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE
derivation_source_file_id = $1"
(lambda ()
(proc inferior inferior-store))
(lambda vals
+ (simple-format #t "debug: returning inferior to pool\n")
(cons 'result vals)))))
#:timeout 20))
#:unwind? #t)
@@ -1853,26 +1862,24 @@ SELECT 1 FROM derivation_source_file_nars WHERE
derivation_source_file_id = $1"
(fibers-delay
(lambda ()
(let ((packages-data
- (with-resource-from-pool inf-and-store-pool res
- (match res
- ((inferior . inferior-store)
- (with-time-logging "getting all inferior package data"
- (let ((packages
- pkg-to-replacement-hash-table
- (inferior-packages-plus-replacements inferior)))
- (all-inferior-packages-data
- inferior
- packages
- pkg-to-replacement-hash-table))))))))
+ (call-with-inferior
+ (lambda (inferior inferior-store)
+ (with-time-logging "getting all inferior package data"
+ (let ((packages
+ pkg-to-replacement-hash-table
+ (inferior-packages-plus-replacements inferior)))
+ (all-inferior-packages-data
+ inferior
+ packages
+ pkg-to-replacement-hash-table)))))))
(with-resource-from-pool postgresql-connection-pool conn
(insert-packages conn packages-data))))))
(define (extract-and-store-lint-checkers-and-warnings)
(define inferior-lint-checkers-data
- (with-resource-from-pool inf-and-store-pool res
- (match res
- ((inferior . inferior-store)
- (inferior-lint-checkers inferior)))))
+ (call-with-inferior
+ (lambda (inferior inferior-store)
+ (inferior-lint-checkers inferior))))
(when inferior-lint-checkers-data
(letpar& ((lint-checker-ids
