cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Finish chasing the call-with-resource-pool bug

Browse source 
This took a while to find as process-job would just get stuck, and this wasn't
directly related to any particular change, just that more fibers increased the
chance of hitting it.

This commit includes lots of the things I changed while debugging.
This commit is contained in:
Christopher Baines 2024-10-31 16:56:30 +00:00
parent af93bdcf5e
commit e67edf54bc
1 changed files with 345 additions and 290 deletions
Download patch file Download diff file Expand all files Collapse all files

635
guix-data-service/jobs/load-new-guix-revision.scm
View file

@ -35,7 +35,9 @@
#:use-module (squee) #:use-module (squee)
#:use-module (gcrypt hash) #:use-module (gcrypt hash)
#:use-module (fibers) #:use-module (fibers)
#:use-module (fibers timers)
#:use-module (fibers channels) #:use-module (fibers channels)
#:use-module (fibers operations)
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix store) #:use-module (guix store)
@ -117,7 +119,9 @@
(missing-store-item-error-item exn) (missing-store-item-error-item exn)
thunk) thunk)
(when on-exception (on-exception)) (when on-exception (on-exception))
(retry-on-missing-store-item thunk)) (retry-on-missing-store-item
thunk
#:on-exception on-exception))
(raise-exception exn))) (raise-exception exn)))
thunk thunk
#:unwind? #t)) #:unwind? #t))
@ -929,21 +933,19 @@
(define (update-derivation-ids-hash-table! conn (define (update-derivation-ids-hash-table! conn
derivation-ids-hash-table derivation-ids-hash-table
derivations) derivation-file-names)
(define derivations-count (length derivations)) (define derivations-count (vector-length derivation-file-names))
(simple-format #t "debug: update-derivation-ids-hash-table!: ~A file-names\n"
derivations-count)
(let ((missing-file-names (let ((missing-file-names
(fold (vector-fold
(lambda (drv result) (lambda (_ result file-name)
(if (hash-ref derivation-ids-hash-table (if (hash-ref derivation-ids-hash-table
(derivation-file-name drv)) file-name)
result result
(cons (derivation-file-name drv) (cons file-name
result))) result)))
'() '()
derivations))) derivation-file-names)))
(simple-format (simple-format
#t "debug: update-derivation-ids-hash-table!: lookup ~A file-names, ~A not cached\n" #t "debug: update-derivation-ids-hash-table!: lookup ~A file-names, ~A not cached\n"
@ -961,29 +963,11 @@
(exec-query conn (select-existing-derivations chunk)))) (exec-query conn (select-existing-derivations chunk))))
(chunk! missing-file-names 1000))))) (chunk! missing-file-names 1000)))))
(define (insert-missing-derivations postgresql-connection-pool (define* (insert-missing-derivations postgresql-connection-pool
utility-thread-channel utility-thread-channel
derivation-ids-hash-table derivation-ids-hash-table
unfiltered-derivations) unfiltered-derivations
#:key (log-tag "unspecified"))
(define (ensure-input-derivations-exist input-derivation-file-names)
(unless (null? input-derivation-file-names)
;; Ensure all the input derivations exist
(for-each
(lambda (chunk)
(simple-format
#t "debug: ensure-input-derivations-exist: processing ~A derivations\n"
(length chunk))
(insert-missing-derivations
postgresql-connection-pool
utility-thread-channel
derivation-ids-hash-table
(call-with-worker-thread
utility-thread-channel
(lambda ()
(map read-derivation-from-file chunk)))))
(chunk! input-derivation-file-names 1000))))
(define (insert-into-derivations conn drvs) (define (insert-into-derivations conn drvs)
(string-append (string-append
@ -1011,163 +995,203 @@
" RETURNING id" " RETURNING id"
";")) ";"))
(with-time-logging (define (insert-derivations)
(simple-format (with-resource-from-pool postgresql-connection-pool conn
#f "insert-missing-derivations: inserting ~A derivations" (update-derivation-ids-hash-table!
(length unfiltered-derivations)) conn
(let ((derivations derivation-ids-hash-table
derivation-ids (let ((file-names-vector
(with-resource-from-pool postgresql-connection-pool conn (make-vector (length unfiltered-derivations))))
(update-derivation-ids-hash-table! conn (for-each
derivation-ids-hash-table (lambda (i drv)
unfiltered-derivations) (vector-set! file-names-vector
i
(derivation-file-name drv)))
(iota (vector-length file-names-vector))
unfiltered-derivations)
file-names-vector))
(let ((derivations (let ((derivations
;; Do this while holding the PostgreSQL connection to ;; Do this while holding the PostgreSQL connection to
;; avoid conflicts with other fibers ;; avoid conflicts with other fibers
(filter-map (lambda (derivation) (delete-duplicates
(if (hash-ref derivation-ids-hash-table (filter-map (lambda (derivation)
(derivation-file-name (if (hash-ref derivation-ids-hash-table
derivation)) (derivation-file-name
#f derivation))
derivation)) #f
unfiltered-derivations))) derivation))
(if (null? derivations) unfiltered-derivations))))
(values '() '()) (if (null? derivations)
(let ((derivation-ids (values '() '())
(append-map! (begin
(lambda (chunk)
(map (lambda (result)
(string->number (car result)))
(exec-query conn (insert-into-derivations conn chunk))))
(chunk derivations 500))))
;; Do this while holding the connection so that other
;; fibers don't also try inserting the same derivations
(with-time-logging
"insert-missing-derivations: updating hash table"
(for-each (lambda (derivation derivation-id)
(hash-set! derivation-ids-hash-table
(derivation-file-name derivation)
derivation-id))
derivations
derivation-ids))
(values derivations
derivation-ids)))))))
(unless (null? derivations)
(parallel-via-fibers
(with-time-logging
"insert-missing-derivations: inserting sources"
(fibers-for-each
(lambda (derivation-id derivation)
(let ((sources (derivation-sources derivation)))
(unless (null? sources)
(let ((sources-ids
(with-resource-from-pool postgresql-connection-pool conn
(insert-derivation-sources conn
derivation-id
sources))))
(par-map&
(lambda (id source-file)
(when
(with-resource-from-pool postgresql-connection-pool conn
(match
(exec-query
conn
"
SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(list (number->string id)))
(()
;; Insert a placeholder to avoid other fibers
;; working on this source file
(insert-placeholder-derivation-source-file-nar
conn
id)
#t)
(_ #f)))
(let ((nar-bytevector
(call-with-worker-thread
utility-thread-channel
(lambda ()
(call-with-values
(lambda ()
(open-bytevector-output-port))
(lambda (port get-bytevector)
(unless (file-exists? source-file)
(raise-exception
(make-missing-store-item-error
source-file)))
(write-file source-file port)
(let ((res (get-bytevector)))
(close-port port) ; maybe reduces memory?
res)))))))
(letpar&
((compressed-nar-bytevector
(call-with-worker-thread
utility-thread-channel
(lambda ()
(call-with-values
(lambda ()
(open-bytevector-output-port))
(lambda (port get-bytevector)
(call-with-lzip-output-port port
(lambda (port)
(put-bytevector port nar-bytevector))
#:level 9)
(let ((res (get-bytevector)))
(close-port port) ; maybe reduces memory?
res))))))
(hash
(call-with-worker-thread
utility-thread-channel
(lambda ()
(bytevector->nix-base32-string
(sha256 nar-bytevector)))))
(uncompressed-size (bytevector-length nar-bytevector)))
(with-resource-from-pool postgresql-connection-pool conn
(update-derivation-source-file-nar
conn
id
hash
compressed-nar-bytevector
uncompressed-size))))))
sources-ids
sources)))))
derivation-ids
derivations))
(with-resource-from-pool postgresql-connection-pool conn
(with-time-logging
"insert-missing-derivations: inserting outputs"
(for-each (lambda (derivation-id derivation)
(insert-derivation-outputs conn
derivation-id
(derivation-outputs derivation)))
derivation-ids
derivations)))
(with-time-logging
"insert-missing-derivations: ensure-input-derivations-exist"
(ensure-input-derivations-exist (deduplicate-strings
(map derivation-input-path
(append-map derivation-inputs
derivations))))))
(with-resource-from-pool postgresql-connection-pool conn
(with-time-logging
(simple-format (simple-format
#f "insert-missing-derivations: inserting inputs for ~A derivations" (current-error-port)
(length derivations)) "insert-missing-derivations: inserting ~A derivations (~A)\n"
(insert-derivation-inputs conn (length unfiltered-derivations)
derivation-ids log-tag)
derivations))))))) (let ((derivation-ids
(append-map!
(lambda (chunk)
(map (lambda (result)
(string->number (car result)))
(exec-query conn (insert-into-derivations conn chunk))))
(chunk derivations 500))))
(define (derivation-file-names->derivation-ids postgresql-connection-pool ;; Do this while holding the connection so that other
utility-thread-channel ;; fibers don't also try inserting the same derivations
derivation-ids-hash-table (with-time-logging
derivation-file-names) (string-append "insert-missing-derivations: updating hash table (" log-tag ")")
(for-each (lambda (derivation derivation-id)
(hash-set! derivation-ids-hash-table
(derivation-file-name derivation)
derivation-id))
derivations
derivation-ids))
(simple-format
(current-error-port)
"insert-missing-derivations: finished inserting ~A derivations (~A)\n"
(length unfiltered-derivations)
log-tag)
(values derivations
derivation-ids)))))))
(define (insert-sources derivations derivation-ids)
(with-time-logging
(string-append "insert-missing-derivations: inserting sources (" log-tag ")")
(fibers-for-each
(lambda (derivation-id derivation)
(let ((sources (derivation-sources derivation)))
(unless (null? sources)
(let ((sources-ids
(with-resource-from-pool postgresql-connection-pool conn
(insert-derivation-sources conn
derivation-id
sources))))
(fibers-for-each
(lambda (id source-file)
(when
(with-resource-from-pool postgresql-connection-pool conn
(match
(exec-query
conn
"
SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(list (number->string id)))
(()
;; Insert a placeholder to avoid other fibers
;; working on this source file
(insert-placeholder-derivation-source-file-nar
conn
id)
#t)
(_ #f)))
;; Use the utility-thread-channel to control concurrency here,
;; to avoid using too much memory
(call-with-worker-thread
utility-thread-channel
(lambda ()
(let ((nar-bytevector
(call-with-values
(lambda ()
(open-bytevector-output-port))
(lambda (port get-bytevector)
(unless (file-exists? source-file)
(raise-exception
(make-missing-store-item-error
source-file)))
(write-file source-file port)
(let ((res (get-bytevector)))
(close-port port) ; maybe reduces memory?
res)))))
(let ((compressed-nar-bytevector
(call-with-values
(lambda ()
(open-bytevector-output-port))
(lambda (port get-bytevector)
(call-with-lzip-output-port port
(lambda (port)
(put-bytevector port nar-bytevector))
#:level 9)
(let ((res (get-bytevector)))
(close-port port) ; maybe reduces memory?
res))))
(hash
(bytevector->nix-base32-string
(sha256 nar-bytevector)))
(uncompressed-size
(bytevector-length nar-bytevector)))
(with-resource-from-pool postgresql-connection-pool conn
(update-derivation-source-file-nar
conn
id
hash
compressed-nar-bytevector
uncompressed-size))))))))
sources-ids
sources)))))
derivation-ids
derivations)))
(let ((derivations
derivation-ids
(insert-derivations)))
(unless (null? derivations)
(parallel-via-fibers
(insert-sources derivations
derivation-ids)
(with-time-logging
(string-append "insert-missing-derivations: inserting outputs ("
log-tag ")")
(with-resource-from-pool postgresql-connection-pool conn
(for-each (lambda (derivation-id derivation)
(insert-derivation-outputs conn
derivation-id
(derivation-outputs derivation)))
derivation-ids
derivations)))
(with-time-logging
(string-append
"insert-missing-derivations: ensure-input-derivations-exist ("
log-tag ")")
(let ((input-derivations
(map
derivation-input-derivation
(append-map derivation-inputs
derivations))))
(unless (null? input-derivations)
;; Ensure all the input derivations exist
(for-each
(lambda (chunk)
(insert-missing-derivations
postgresql-connection-pool
utility-thread-channel
derivation-ids-hash-table
chunk
#:log-tag log-tag))
(chunk! input-derivations 1000))))))
(string-append "insert-missing-derivations: done parallel (" log-tag ")")
(with-resource-from-pool postgresql-connection-pool conn
(with-time-logging
(simple-format
#f "insert-missing-derivations: inserting inputs for ~A derivations (~A)"
(length derivations)
log-tag)
(insert-derivation-inputs conn
derivation-ids
derivations))))))
(define* (derivation-file-names->derivation-ids postgresql-connection-pool
utility-thread-channel
read-derivations/fiberized
derivation-ids-hash-table
derivation-file-names
#:key (log-tag "unspecified"))
(define derivations-count (define derivations-count
(vector-length derivation-file-names)) (vector-length derivation-file-names))
@ -1175,8 +1199,9 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
#() #()
(begin (begin
(simple-format (simple-format
#t "debug: derivation-file-names->derivation-ids: processing ~A derivations\n" #t "debug: derivation-file-names->derivation-ids: processing ~A derivations (~A)\n"
derivations-count) derivations-count
log-tag)
(let* ((missing-derivation-filenames (let* ((missing-derivation-filenames
(deduplicate-strings (deduplicate-strings
@ -1189,32 +1214,24 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
result result
(cons derivation-file-name result)))) (cons derivation-file-name result))))
'() '()
derivation-file-names))) derivation-file-names))))
(missing-derivations-chunked-promises (let ((chunks (chunk! missing-derivation-filenames 1000)))
(map (for-each
(lambda (chunk) (lambda (i missing-derivation-file-names-chunk)
(fibers-delay (let ((missing-derivations-chunk
(lambda () (read-derivations/fiberized
(map (lambda (filename) missing-derivation-file-names-chunk)))
(if (file-exists? filename) (simple-format
(read-derivation-from-file filename) #t "debug: derivation-file-names->derivation-ids: processing chunk ~A (~A)\n"
(raise-exception i
(make-missing-store-item-error log-tag)
filename))))
chunk))))
(chunk! missing-derivation-filenames 1000))))
(for-each
(lambda (missing-derivation-chunk-promise)
(let ((missing-derivations-chunk
(fibers-force
missing-derivation-chunk-promise)))
(unless (null? missing-derivations-chunk)
(insert-missing-derivations postgresql-connection-pool (insert-missing-derivations postgresql-connection-pool
utility-thread-channel utility-thread-channel
derivation-ids-hash-table derivation-ids-hash-table
missing-derivations-chunk)))) missing-derivations-chunk
missing-derivations-chunked-promises) #:log-tag log-tag)))
(iota (length chunks))
chunks))
(let ((all-ids (let ((all-ids
(vector-map (vector-map
@ -1222,34 +1239,12 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(if derivation-file-name (if derivation-file-name
(or (hash-ref derivation-ids-hash-table (or (hash-ref derivation-ids-hash-table
derivation-file-name) derivation-file-name)
;; If a derivation ID can't be found, update the
;; hash table then check again
(with-resource-from-pool postgresql-connection-pool conn
(for-each
(lambda (missing-derivations-chunked-promise)
(update-derivation-ids-hash-table!
conn
derivation-ids-hash-table
(fibers-force missing-derivations-chunked-promise)))
missing-derivations-chunked-promises)
(or (hash-ref derivation-ids-hash-table
derivation-file-name)
(error (error
(simple-format #f "missing derivation id (~A)" (simple-format #f "missing derivation id (~A)"
derivation-file-name))))) derivation-file-name)))
#f)) #f))
derivation-file-names))) derivation-file-names)))
(with-resource-from-pool postgresql-connection-pool conn
(simple-format
(current-error-port)
"guix-data-service: clearing the derivation-ids-hash-table\n")
(hash-clear! derivation-ids-hash-table))
;; Just in case this helps clear memory
(for-each fibers-promise-reset
missing-derivations-chunked-promises)
all-ids))))) all-ids)))))
(prevent-inlining-for-tests derivation-file-names->derivation-ids) (prevent-inlining-for-tests derivation-file-names->derivation-ids)
@ -1489,6 +1484,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(cons inferior inferior-store))) (cons inferior inferior-store)))
parallelism parallelism
#:min-size 0 #:min-size 0
#:name "inferior"
#:idle-seconds 30 #:idle-seconds 30
#:destructor (match-lambda #:destructor (match-lambda
((inferior . store) ((inferior . store)
@ -1501,7 +1497,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(inferior-eval '(@ (guix packages) %supported-systems) (inferior-eval '(@ (guix packages) %supported-systems)
inferior))))) inferior)))))
(result (result
(par-map& (fibers-map
(lambda (system) (lambda (system)
(with-resource-from-pool inferior-and-store-pool res (with-resource-from-pool inferior-and-store-pool res
(match res (match res
@ -1725,6 +1721,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
guix-source store-item guix-source store-item
guix-derivation guix-derivation
utility-thread-channel utility-thread-channel
read-derivations/fiberized
derivation-ids-hash-table derivation-ids-hash-table
#:key skip-system-tests? #:key skip-system-tests?
extra-inferior-environment-variables extra-inferior-environment-variables
@ -1776,6 +1773,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
parallelism parallelism
#:min-size 0 #:min-size 0
#:idle-seconds 20 #:idle-seconds 20
#:name "inferior"
#:destructor #:destructor
(match-lambda (match-lambda
((inferior . store) ((inferior . store)
@ -1853,6 +1851,8 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
'load-new-guix-revision-inserts)) 'load-new-guix-revision-inserts))
db-conn) db-conn)
1 1
#:name "postgres"
#:assume-reliable-waiters? #t
#:min-size 0)) #:min-size 0))
(define package-ids-promise (define package-ids-promise
@ -1892,7 +1892,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
conn descriptions-by-locale)))) conn descriptions-by-locale))))
inferior-lint-checkers-data)))) inferior-lint-checkers-data))))
(lint-warnings-data (lint-warnings-data
(par-map& (fibers-map
(match-lambda (match-lambda
((checker-name _ network-dependent?) ((checker-name _ network-dependent?)
(and (and (not network-dependent?) (and (and (not network-dependent?)
@ -1978,8 +1978,10 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(derivation-file-names->derivation-ids (derivation-file-names->derivation-ids
postgresql-connection-pool postgresql-connection-pool
utility-thread-channel utility-thread-channel
read-derivations/fiberized
derivation-ids-hash-table derivation-ids-hash-table
derivations-vector))) derivations-vector
#:log-tag (simple-format #f "~A:~A" system target))))
(guix-revision-id (guix-revision-id
(fibers-force guix-revision-id-promise)) (fibers-force guix-revision-id-promise))
(package-ids (fibers-force package-ids-promise)) (package-ids (fibers-force package-ids-promise))
@ -2013,75 +2015,93 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(fibers-force guix-revision-id-promise) (fibers-force guix-revision-id-promise)
(number->string (number->string
(system->system-id conn system)) (system->system-id conn system))
(or target ""))))) (or target ""))))
'finished)
(let ((get-derivations/fiberized (let ((get-derivations/fiberized
(fiberize get-derivations (fiberize get-derivations
;; Limit concurrency here to keep focused on specific ;; Limit concurrency here to keep focused on specific
;; systems until they've been fully processed ;; systems until they've been fully processed
#:parallelism parallelism))) #:parallelism parallelism)))
(par-map& (with-time-logging "extract-and-store-package-derivations"
(match-lambda (fibers-map-with-progress
((system . target) (match-lambda
(retry-on-missing-store-item ((system . target)
(lambda () (retry-on-missing-store-item
(process-system-and-target system target (lambda ()
get-derivations/fiberized))))) (process-system-and-target system target
(call-with-inferior get-derivations/fiberized)))))
(lambda (inferior inferior-store) (list
(inferior-fetch-system-target-pairs inferior)))))) (call-with-inferior
(lambda (inferior inferior-store)
(inferior-fetch-system-target-pairs inferior))))
#:report
(lambda (data)
(for-each
(match-lambda
((result (system . target))
(simple-format #t "~A ~A: ~A\n"
system target result)))
data))))))
(define (extract-and-store-system-tests) (define (extract-and-store-system-tests)
(if skip-system-tests? (if skip-system-tests?
(begin (begin
(simple-format #t "debug: skipping system tests\n") (simple-format #t "debug: skipping system tests\n")
'()) '())
(let ((data-with-derivation-file-names (with-time-logging "extract-and-store-system-tests"
(call-with-inferior (let ((data-with-derivation-file-names
(lambda (inferior inferior-store) (call-with-inferior
(with-time-logging "getting inferior system tests" (lambda (inferior inferior-store)
(all-inferior-system-tests (with-time-logging "getting inferior system tests"
inferior (all-inferior-system-tests
inferior-store inferior
guix-source inferior-store
commit)))))) guix-source
(when data-with-derivation-file-names commit))))))
(let ((data-with-derivation-ids (when data-with-derivation-file-names
(map (match-lambda (let ((data-with-derivation-ids
((name description derivation-file-names-by-system location-data) (map (match-lambda
(list name ((name description derivation-file-names-by-system location-data)
description (list name
(let ((systems description
(map car derivation-file-names-by-system)) (let ((systems
(derivation-ids (map car derivation-file-names-by-system))
(derivation-file-names->derivation-ids (derivation-ids
postgresql-connection-pool (derivation-file-names->derivation-ids
utility-thread-channel postgresql-connection-pool
derivation-ids-hash-table utility-thread-channel
(list->vector read-derivations/fiberized
(map cdr derivation-file-names-by-system))))) derivation-ids-hash-table
(map cons systems derivation-ids)) (list->vector
location-data))) (map cdr derivation-file-names-by-system)))))
data-with-derivation-file-names))) (map cons systems derivation-ids))
(with-resource-from-pool postgresql-connection-pool conn location-data)))
(insert-system-tests-for-guix-revision data-with-derivation-file-names)))
conn (with-resource-from-pool postgresql-connection-pool conn
(fibers-force guix-revision-id-promise) (insert-system-tests-for-guix-revision
data-with-derivation-ids))))))) conn
(fibers-force guix-revision-id-promise)
data-with-derivation-ids))))))))
(with-time-logging (with-time-logging
(simple-format #f "extract-information-from: ~A\n" store-item) (simple-format #f "extract-information-from: ~A\n" store-item)
(parallel-via-fibers (parallel-via-fibers
(fibers-force package-ids-promise) (begin
(fibers-force package-ids-promise)
#f)
(extract-and-store-package-derivations) (extract-and-store-package-derivations)
(retry-on-missing-store-item extract-and-store-system-tests) (retry-on-missing-store-item extract-and-store-system-tests)
(extract-and-store-lint-checkers-and-warnings))) (with-time-logging "extract-and-store-lint-checkers-and-warnings"
(extract-and-store-lint-checkers-and-warnings))))
#t) #t)
(prevent-inlining-for-tests extract-information-from) (prevent-inlining-for-tests extract-information-from)
(define (load-channel-instances utility-thread-channel (define (load-channel-instances utility-thread-channel
read-derivations/fiberized
derivation-ids-hash-table derivation-ids-hash-table
git-repository-id commit git-repository-id commit
channel-derivations-by-system) channel-derivations-by-system)
@ -2113,6 +2133,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(make-resource-pool (make-resource-pool
(const channel-instances-conn) (const channel-instances-conn)
1 1
#:name "postgres"
#:min-size 0))) #:min-size 0)))
(unless existing-guix-revision-id (unless existing-guix-revision-id
@ -2130,6 +2151,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(derivation-file-names->derivation-ids (derivation-file-names->derivation-ids
postgresql-connection-pool postgresql-connection-pool
utility-thread-channel utility-thread-channel
read-derivations/fiberized
derivation-ids-hash-table derivation-ids-hash-table
(list->vector (map cdr derivations-by-system))))) (list->vector (map cdr derivations-by-system)))))
@ -2150,15 +2172,34 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
#:key skip-system-tests? parallelism #:key skip-system-tests? parallelism
extra-inferior-environment-variables) extra-inferior-environment-variables)
(define utility-thread-channel (define utility-thread-channel
(make-worker-thread-channel ;; There might be high demand for this, so order the requests
(const '()) (make-queueing-channel
#:parallelism parallelism)) (call-with-default-io-waiters
(lambda ()
(make-worker-thread-channel
(const '())
#:parallelism parallelism)))))
(define (read-derivations filenames)
(call-with-worker-thread
utility-thread-channel
(lambda ()
(map (lambda (filename)
(if (file-exists? filename)
(read-derivation-from-file filename)
(raise-exception
(make-missing-store-item-error
filename))))
filenames))))
(define read-derivations/fiberized
(fiberize read-derivations
;; Don't do this in parallel as there's caching involved with
;; read-derivation-from-file
#:parallelism 1))
(define derivation-ids-hash-table (define derivation-ids-hash-table
(make-hash-table)) (make-hash-table))
(%worker-thread-default-timeout #f)
(let* ((git-repository-fields (let* ((git-repository-fields
(select-git-repository conn git-repository-id)) (select-git-repository conn git-repository-id))
(git-repository-url (git-repository-url
@ -2188,6 +2229,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
channel-derivations-by-system channel-derivations-by-system
(fibers-force channel-derivations-by-system-promise))) (fibers-force channel-derivations-by-system-promise)))
(load-channel-instances utility-thread-channel (load-channel-instances utility-thread-channel
read-derivations/fiberized
derivation-ids-hash-table derivation-ids-hash-table
git-repository-id commit git-repository-id commit
channel-derivations-by-system))) channel-derivations-by-system)))
@ -2214,6 +2256,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
commit guix-source store-item commit guix-source store-item
guix-derivation guix-derivation
utility-thread-channel utility-thread-channel
read-derivations/fiberized
derivation-ids-hash-table derivation-ids-hash-table
#:skip-system-tests? #:skip-system-tests?
skip-system-tests? skip-system-tests?
@ -2633,6 +2676,9 @@ SKIP LOCKED")
(define* (process-load-new-guix-revision-job id #:key skip-system-tests? (define* (process-load-new-guix-revision-job id #:key skip-system-tests?
extra-inferior-environment-variables extra-inferior-environment-variables
parallelism) parallelism)
(define finished-channel
(make-channel))
(define result (define result
(with-postgresql-connection (with-postgresql-connection
(simple-format #f "load-new-guix-revision ~A" id) (simple-format #f "load-new-guix-revision ~A" id)
@ -2642,12 +2688,20 @@ SKIP LOCKED")
;; instances have the data updated. ;; instances have the data updated.
(fix-derivation-output-details-hash-encoding conn) (fix-derivation-output-details-hash-encoding conn)
(%worker-thread-default-timeout #f)
(resource-pool-retry-checkout-timeout 120)
(exec-query conn "BEGIN") (exec-query conn "BEGIN")
(spawn-fiber (spawn-fiber
(lambda () (lambda ()
(while #t (while (perform-operation
(sleep 30) (choice-operation
(wrap-operation (get-operation finished-channel)
(const #f))
(wrap-operation (sleep-operation 20)
(const #t))))
(let ((stats (gc-stats))) (let ((stats (gc-stats)))
(simple-format (simple-format
@ -2752,4 +2806,5 @@ SKIP LOCKED")
"update-derivation-outputs-statistics" "update-derivation-outputs-statistics"
(update-derivation-outputs-statistics conn)))))) (update-derivation-outputs-statistics conn))))))
(put-message finished-channel #t)
result) result)