diff options
Diffstat (limited to 'guix-data-service/jobs/load-new-guix-revision.scm')
| -rw-r--r-- | guix-data-service/jobs/load-new-guix-revision.scm | 100 |
1 files changed, 62 insertions, 38 deletions
diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm index f6d4292..5c2744c 100644 --- a/guix-data-service/jobs/load-new-guix-revision.scm +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -1160,6 +1160,7 @@ (let* ((inferior-store (open-connection)) (inferior (start-inferior inferior-store))) (ensure-non-blocking-store-connection inferior-store) + (set-build-options inferior-store #:fallback? #t) (make-inferior-non-blocking! inferior) (call-with-blocked-asyncs (lambda () @@ -1304,7 +1305,7 @@ (let* ((derivation (or (and=> - (inferior-eval-with-store + (inferior-eval-with-store/non-blocking inf store '(lambda (store) @@ -1399,7 +1400,8 @@ inf)) -(define* (extract-information-from conn store guix-revision-id commit +(define* (extract-information-from conn long-running-store-connection + guix-revision-id commit guix-source store-path #:key skip-system-tests? parallelism) @@ -1410,7 +1412,9 @@ ;; inferior Guix works, even if it's build using a different ;; glibc version (string-append - (glibc-locales-for-guix-store-path store store-path) + (with-store-connection + (lambda (store) + (glibc-locales-for-guix-store-path store store-path))) "/lib/locale" ":" (getenv "GUIX_LOCPATH"))) @@ -1423,15 +1427,21 @@ guix-locpath))) (ensure-non-blocking-store-connection inferior-store) (make-inferior-non-blocking! inferior) + + (simple-format #t "debug: started new inferior and store connection\n") + (cons inferior inferior-store))) parallelism #:min-size 0 - #:idle-seconds 10 - #:destructor (match-lambda - ((inferior . store) - ;; Don't close the store connection here, because there - ;; are temporary roots to keep alive - (close-inferior inferior))))) + #:idle-seconds 2 + #:destructor + (match-lambda + ((inferior . store) + (simple-format + #t "debug: closing inferior and associated store connection\n") + + (close-connection store) + (close-inferior inferior))))) (define add-temp-root/long-running-store (let ((channel (make-channel))) @@ -1439,22 +1449,12 @@ (spawn-fiber (lambda () (let loop ((filename (get-message channel))) - (add-temp-root store filename) + (add-temp-root long-running-store-connection filename) (loop (get-message channel))))) (lambda (filename) (put-message channel filename)))) - (define lock-num - ;; I'm seeing problems with the guix-dameon WAL growing excessively, which - ;; I think is happening when processing revivions involving lots of new - ;; derivations. So limit the concurrency here in the hope that this'll - ;; help. - (with-time-logging "getting 'inferior-package-derivations lock" - (lock-advisory-session-lock - conn - 'inferior-package-derivations))) - (simple-format #t "debug: extract-information-from: ~A\n" store-path) (letpar& ((inferior-lint-checkers-and-warnings-data @@ -1484,6 +1484,14 @@ (par-map& (match-lambda ((system . target) + (let loop ((wal-bytes (stat:size (stat "/var/guix/db/db.sqlite-wal")))) + (when (> wal-bytes 200000000) + (simple-format #t "debug: guix-daemon WAL is large (~A), waiting\n" + wal-bytes) + + (sleep 30) + (loop (stat:size (stat "/var/guix/db/db.sqlite-wal"))))) + (with-resource-from-pool inf-and-store-pool res (with-time-logging (simple-format #f "getting derivations for ~A" (cons system target)) @@ -1534,7 +1542,6 @@ pkg-to-replacement-hash-table)))))))) (destroy-resource-pool inf-and-store-pool) - (unlock-advisory-session-lock conn lock-num) (simple-format #t "debug: finished loading information from inferior\n") @@ -1658,7 +1665,7 @@ (prevent-inlining-for-tests load-channel-instances) -(define* (load-new-guix-revision conn store git-repository-id commit +(define* (load-new-guix-revision conn git-repository-id commit #:key skip-system-tests? parallelism) (let* ((git-repository-fields (select-git-repository conn git-repository-id)) @@ -1670,10 +1677,12 @@ (channel (name 'guix) (url git-repository-url) (commit commit))) + (initial-store-connection + (open-store-connection)) (source-and-channel-derivations-by-system (channel->source-and-derivations-by-system conn - store + initial-store-connection channel-for-commit fetch-with-authentication? #:parallelism parallelism)) @@ -1686,16 +1695,24 @@ channel-derivations-by-system))) (let ((store-item (channel-derivations-by-system->guix-store-item - store + initial-store-connection channel-derivations-by-system))) (if store-item (and - (extract-information-from conn store - guix-revision-id - commit guix-source store-item - #:skip-system-tests? - skip-system-tests? - #:parallelism parallelism) + (with-store-connection + (lambda (store) + (add-temp-root store store-item) + + ;; Close the initial connection now that the store-item has a + ;; root + (close-connection initial-store-connection) + + (extract-information-from conn store + guix-revision-id + commit guix-source store-item + #:skip-system-tests? + skip-system-tests? + #:parallelism parallelism))) (if (defined? 'channel-news-for-commit (resolve-module '(guix channels))) @@ -1720,6 +1737,7 @@ (begin (simple-format #t "Failed to generate store item for ~A\n" commit) + (close-connection initial-store-connection) #f))))) (define (enqueue-load-new-guix-revision-job conn git-repository-id commit source) @@ -2078,6 +2096,15 @@ SKIP LOCKED") (string=? priority "t")))) (exec-query conn query))) +(define (open-store-connection) + (let ((store (open-connection))) + (ensure-non-blocking-store-connection store) + (set-build-options store #:fallback? #t) + + store)) + +(prevent-inlining-for-tests open-store-connection) + (define (with-store-connection f) (with-store store (ensure-non-blocking-store-connection store) @@ -2119,14 +2146,11 @@ SKIP LOCKED") (lambda () (with-throw-handler #t (lambda () - (with-store-connection - (lambda (store) - (load-new-guix-revision conn - store - git-repository-id - commit - #:skip-system-tests? #t - #:parallelism parallelism)))) + (load-new-guix-revision conn + git-repository-id + commit + #:skip-system-tests? #t + #:parallelism parallelism)) (lambda (key . args) (simple-format (current-error-port) "error: load-new-guix-revision: ~A ~A\n" |