Improve logging around use of inferiors

1 files 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