Use drain? #t for fibers when loading revisions
To check that there's no left over fibers.
This commit is contained in:
parent
f7f4e70d28
commit
0dd14c0a67
5 changed files with 178 additions and 129 deletions
|
|
@ -22,6 +22,7 @@
|
|||
#:use-module (ice-9 exceptions)
|
||||
#:use-module (squee)
|
||||
#:use-module (prometheus)
|
||||
#:use-module (knots)
|
||||
#:use-module (guix-data-service config)
|
||||
#:export (get-database-config
|
||||
%database-metrics-registry
|
||||
|
|
@ -226,17 +227,31 @@
|
|||
(lambda ()
|
||||
(exec-query conn "ROLLBACK;"))
|
||||
#:unwind? #t)
|
||||
;; TODO Include the stack in the exception via knots
|
||||
(raise-exception exn))
|
||||
(lambda ()
|
||||
(let ((result
|
||||
(parameterize
|
||||
((%postgresql-in-transaction? #t))
|
||||
(f conn))))
|
||||
(exec-query conn (if always-rollback?
|
||||
"ROLLBACK;"
|
||||
"COMMIT;"))
|
||||
result))
|
||||
(with-exception-handler
|
||||
(lambda (exn)
|
||||
(let ((stack
|
||||
(match (fluid-ref %stacks)
|
||||
((stack-tag . prompt-tag)
|
||||
(make-stack #t
|
||||
0 prompt-tag
|
||||
0 (and prompt-tag 1)))
|
||||
(_
|
||||
(make-stack #t)))))
|
||||
(raise-exception
|
||||
(make-exception
|
||||
exn
|
||||
(make-knots-exception stack)))))
|
||||
(lambda ()
|
||||
(let ((result
|
||||
(parameterize
|
||||
((%postgresql-in-transaction? #t))
|
||||
(f conn))))
|
||||
(exec-query conn (if always-rollback?
|
||||
"ROLLBACK;"
|
||||
"COMMIT;"))
|
||||
result))))
|
||||
#:unwind? #t))
|
||||
|
||||
(define (check-test-database! conn)
|
||||
|
|
|
|||
|
|
@ -177,9 +177,13 @@
|
|||
inf)))
|
||||
string<?))
|
||||
|
||||
(define (all-inferior-system-tests inf store guix-source guix-commit)
|
||||
(define* (all-inferior-system-tests inf store guix-source guix-commit
|
||||
#:key (ignore-systems '()))
|
||||
(define inf-systems
|
||||
(inferior-guix-systems inf))
|
||||
(lset-difference
|
||||
string=?
|
||||
(inferior-guix-systems inf)
|
||||
ignore-systems))
|
||||
|
||||
(define extract
|
||||
`(lambda (store)
|
||||
|
|
@ -1304,9 +1308,8 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
|
|||
(lambda (conn)
|
||||
(let ((drv (read-derivation-from-file file-name))
|
||||
(postgresql-connection-pool
|
||||
(make-resource-pool
|
||||
(const conn)
|
||||
1
|
||||
(make-fixed-size-resource-pool
|
||||
(list conn)
|
||||
#:name "postgres"))
|
||||
(call-with-utility-thread
|
||||
(lambda (thunk)
|
||||
|
|
@ -1346,10 +1349,13 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
|
|||
1000
|
||||
input-derivations)))))
|
||||
|
||||
(fix-derivation-inputs conn drv))))))))))
|
||||
(fix-derivation-inputs conn drv))))
|
||||
|
||||
(destroy-resource-pool postgresql-connection-pool)))))))
|
||||
#:unwind? #t))
|
||||
#:hz 0
|
||||
#:parallelism 1))
|
||||
#:parallelism 1
|
||||
#:drain? #t))
|
||||
|
||||
(define (fix-derivation-source-file-nar id)
|
||||
(run-fibers
|
||||
|
|
@ -1358,9 +1364,8 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
|
|||
"fix"
|
||||
(lambda (conn)
|
||||
(let ((postgresql-connection-pool
|
||||
(make-resource-pool
|
||||
(const conn)
|
||||
1
|
||||
(make-fixed-size-resource-pool
|
||||
(list conn)
|
||||
#:name "postgres")))
|
||||
(match (exec-query
|
||||
conn
|
||||
|
|
@ -1371,13 +1376,16 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
|
|||
(compute-and-update-derivation-source-file-nar
|
||||
postgresql-connection-pool
|
||||
id
|
||||
store-path)))))))
|
||||
store-path)))
|
||||
|
||||
(destroy-resource-pool postgresql-connection-pool)))))
|
||||
#:hz 0
|
||||
#:parallelism 1))
|
||||
#:parallelism 1
|
||||
#:drain? #t))
|
||||
|
||||
(define* (derivation-file-names->derivation-ids postgresql-connection-pool
|
||||
call-with-utility-thread
|
||||
read-derivations/fiberized
|
||||
read-derivations/serialised
|
||||
derivation-ids-hash-table
|
||||
derivation-file-names
|
||||
#:key (log-tag "unspecified"))
|
||||
|
|
@ -1414,7 +1422,7 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
|
|||
(chunk-for-each!
|
||||
(lambda (missing-derivation-file-names-chunk)
|
||||
(let ((missing-derivations-chunk
|
||||
(read-derivations/fiberized
|
||||
(read-derivations/serialised
|
||||
missing-derivation-file-names-chunk)))
|
||||
(simple-format
|
||||
#t "debug: derivation-file-names->derivation-ids: processing chunk ~A (~A)\n"
|
||||
|
|
@ -1752,6 +1760,8 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
|
|||
#:unwind? #t)))))
|
||||
systems)))
|
||||
|
||||
(destroy-resource-pool inferior-and-store-pool)
|
||||
|
||||
(cons
|
||||
(channel-instance-checkout channel-instance)
|
||||
result)))
|
||||
|
|
@ -1972,7 +1982,7 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
|
|||
guix-source store-item
|
||||
guix-derivation
|
||||
call-with-utility-thread
|
||||
read-derivations/fiberized
|
||||
read-derivations/serialised
|
||||
derivation-ids-hash-table
|
||||
#:key skip-system-tests?
|
||||
extra-inferior-environment-variables
|
||||
|
|
@ -2268,43 +2278,50 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
|
|||
|
||||
*unspecified*)
|
||||
|
||||
(define get-derivations/parallelism-limiter
|
||||
(make-parallelism-limiter parallelism))
|
||||
(define (get-derivations system target)
|
||||
(let ((derivations-vector (make-vector packages-count)))
|
||||
(with-time-logging
|
||||
(simple-format #f "getting derivations for ~A" (cons system target))
|
||||
(let loop ((start-index 0))
|
||||
(let* ((last-chunk?
|
||||
(>= (+ start-index chunk-size) packages-count))
|
||||
(count
|
||||
(if last-chunk?
|
||||
(- packages-count start-index)
|
||||
chunk-size))
|
||||
(chunk
|
||||
(call-with-inferior
|
||||
(lambda (inferior inferior-store)
|
||||
(ensure-gds-inferior-packages-defined! inferior)
|
||||
;; Limit concurrency here to keep focused on specific systems until
|
||||
;; they've been fully processed
|
||||
(with-parallelism-limiter
|
||||
get-derivations/parallelism-limiter
|
||||
(let ((derivations-vector (make-vector packages-count)))
|
||||
(with-time-logging
|
||||
(simple-format #f "getting derivations for ~A"
|
||||
(cons system target))
|
||||
(let loop ((start-index 0))
|
||||
(let* ((last-chunk?
|
||||
(>= (+ start-index chunk-size) packages-count))
|
||||
(count
|
||||
(if last-chunk?
|
||||
(- packages-count start-index)
|
||||
chunk-size))
|
||||
(chunk
|
||||
(call-with-inferior
|
||||
(lambda (inferior inferior-store)
|
||||
(ensure-gds-inferior-packages-defined! inferior)
|
||||
|
||||
(let ((result
|
||||
(inferior-package-derivations
|
||||
inferior-store
|
||||
inferior
|
||||
system
|
||||
target
|
||||
start-index
|
||||
count)))
|
||||
(let ((result
|
||||
(inferior-package-derivations
|
||||
inferior-store
|
||||
inferior
|
||||
system
|
||||
target
|
||||
start-index
|
||||
count)))
|
||||
|
||||
(when last-chunk?
|
||||
(inferior-cleanup inferior))
|
||||
(when last-chunk?
|
||||
(inferior-cleanup inferior))
|
||||
|
||||
result)))))
|
||||
(vector-copy! derivations-vector
|
||||
start-index
|
||||
chunk)
|
||||
(unless last-chunk?
|
||||
(loop (+ start-index chunk-size))))))
|
||||
derivations-vector))
|
||||
result)))))
|
||||
(vector-copy! derivations-vector
|
||||
start-index
|
||||
chunk)
|
||||
(unless last-chunk?
|
||||
(loop (+ start-index chunk-size))))))
|
||||
derivations-vector)))
|
||||
|
||||
(define (process-system-and-target system target get-derivations)
|
||||
(define (process-system-and-target system target)
|
||||
(with-time-logging
|
||||
(simple-format #f "processing derivations for ~A" (cons system target))
|
||||
(let* ((derivations-vector (get-derivations system target))
|
||||
|
|
@ -2315,7 +2332,7 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
|
|||
(derivation-file-names->derivation-ids
|
||||
postgresql-connection-pool
|
||||
call-with-utility-thread
|
||||
read-derivations/fiberized
|
||||
read-derivations/serialised
|
||||
derivation-ids-hash-table
|
||||
derivations-vector
|
||||
#:log-tag (simple-format #f "~A:~A" system target))))
|
||||
|
|
@ -2345,46 +2362,43 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
|
|||
|
||||
'finished)
|
||||
|
||||
(let ((get-derivations/fiberized
|
||||
(fiberize get-derivations
|
||||
;; Limit concurrency here to keep focused on specific
|
||||
;; systems until they've been fully processed
|
||||
#:parallelism parallelism)))
|
||||
(with-time-logging "extract-and-store-package-derivations"
|
||||
(fibers-map-with-progress
|
||||
(match-lambda
|
||||
((system . target)
|
||||
(retry-on-missing-store-item
|
||||
(lambda ()
|
||||
(process-system-and-target system target
|
||||
get-derivations/fiberized)))))
|
||||
(list
|
||||
(let ((all-system-target-pairs
|
||||
(call-with-inferior
|
||||
(lambda (inferior inferior-store)
|
||||
(inferior-fetch-system-target-pairs inferior)))))
|
||||
(filter
|
||||
(match-lambda
|
||||
((system . target)
|
||||
(if (or (member system ignore-systems)
|
||||
(member target ignore-targets))
|
||||
(begin
|
||||
(simple-format
|
||||
(current-error-port)
|
||||
"ignoring ~A ~A for package derivations\n"
|
||||
system
|
||||
target)
|
||||
#f)
|
||||
#t)))
|
||||
all-system-target-pairs)))
|
||||
#:report
|
||||
(lambda (data)
|
||||
(for-each
|
||||
(match-lambda
|
||||
((result (system . target))
|
||||
(simple-format #t "~A ~A: ~A\n"
|
||||
system target result)))
|
||||
data))))))
|
||||
(with-time-logging "extract-and-store-package-derivations"
|
||||
(fibers-map-with-progress
|
||||
(match-lambda
|
||||
((system . target)
|
||||
(retry-on-missing-store-item
|
||||
(lambda ()
|
||||
(process-system-and-target system target)))))
|
||||
(list
|
||||
(let ((all-system-target-pairs
|
||||
(call-with-inferior
|
||||
(lambda (inferior inferior-store)
|
||||
(inferior-fetch-system-target-pairs inferior)))))
|
||||
(filter
|
||||
(match-lambda
|
||||
((system . target)
|
||||
(if (or (member system ignore-systems)
|
||||
(member target ignore-targets))
|
||||
(begin
|
||||
(simple-format
|
||||
(current-error-port)
|
||||
"ignoring ~A ~A for package derivations\n"
|
||||
system
|
||||
target)
|
||||
#f)
|
||||
#t)))
|
||||
all-system-target-pairs)))
|
||||
#:report
|
||||
(lambda (data)
|
||||
(for-each
|
||||
(match-lambda
|
||||
((result (system . target))
|
||||
(simple-format #t "~A ~A: ~A\n"
|
||||
system target result)))
|
||||
data)))
|
||||
(destroy-parallelism-limiter
|
||||
get-derivations/parallelism-limiter)
|
||||
#t))
|
||||
|
||||
(define (extract-and-store-system-tests)
|
||||
(if skip-system-tests?
|
||||
|
|
@ -2400,7 +2414,8 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
|
|||
inferior
|
||||
inferior-store
|
||||
guix-source
|
||||
commit))))))
|
||||
commit
|
||||
#:ignore-systems ignore-systems))))))
|
||||
(when data-with-derivation-file-names
|
||||
(let ((data-with-derivation-ids
|
||||
(map (match-lambda
|
||||
|
|
@ -2414,7 +2429,7 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
|
|||
(derivation-file-names->derivation-ids
|
||||
postgresql-connection-pool
|
||||
call-with-utility-thread
|
||||
read-derivations/fiberized
|
||||
read-derivations/serialised
|
||||
derivation-ids-hash-table
|
||||
(list->vector
|
||||
(map cdr derivation-file-names-by-system))
|
||||
|
|
@ -2439,12 +2454,15 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
|
|||
(with-time-logging "extract-and-store-lint-checkers-and-warnings"
|
||||
(extract-and-store-lint-checkers-and-warnings))))
|
||||
|
||||
(destroy-resource-pool inf-and-store-pool)
|
||||
(destroy-resource-pool postgresql-connection-pool)
|
||||
|
||||
#t)
|
||||
|
||||
(prevent-inlining-for-tests extract-information-from)
|
||||
|
||||
(define (load-channel-instances call-with-utility-thread
|
||||
read-derivations/fiberized
|
||||
read-derivations/serialised
|
||||
derivation-ids-hash-table
|
||||
git-repository-id commit
|
||||
channel-derivations-by-system)
|
||||
|
|
@ -2473,9 +2491,8 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
|
|||
(insert-guix-revision channel-instances-conn
|
||||
git-repository-id commit)))
|
||||
(postgresql-connection-pool
|
||||
(make-resource-pool
|
||||
(const channel-instances-conn)
|
||||
1
|
||||
(make-fixed-size-resource-pool
|
||||
(list channel-instances-conn)
|
||||
#:name "postgres")))
|
||||
|
||||
(unless existing-guix-revision-id
|
||||
|
|
@ -2493,7 +2510,7 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
|
|||
(derivation-file-names->derivation-ids
|
||||
postgresql-connection-pool
|
||||
call-with-utility-thread
|
||||
read-derivations/fiberized
|
||||
read-derivations/serialised
|
||||
derivation-ids-hash-table
|
||||
(list->vector (map cdr derivations-by-system)))))
|
||||
|
||||
|
|
@ -2537,11 +2554,13 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
|
|||
(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 read-derivations/parallelism-limiter
|
||||
(make-parallelism-limiter 1))
|
||||
(define (read-derivations/serialised . args)
|
||||
(with-parallelism-limiter
|
||||
read-derivations/parallelism-limiter
|
||||
(apply read-derivations args)))
|
||||
|
||||
(define derivation-ids-hash-table
|
||||
(make-hash-table))
|
||||
|
|
@ -2581,7 +2600,7 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
|
|||
channel-derivations-by-system
|
||||
(fibers-force channel-derivations-by-system-promise)))
|
||||
(load-channel-instances call-with-utility-thread
|
||||
read-derivations/fiberized
|
||||
read-derivations/serialised
|
||||
derivation-ids-hash-table
|
||||
git-repository-id commit
|
||||
channel-derivations-by-system)))
|
||||
|
|
@ -2608,7 +2627,7 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
|
|||
commit guix-source store-item
|
||||
guix-derivation
|
||||
call-with-utility-thread
|
||||
read-derivations/fiberized
|
||||
read-derivations/serialised
|
||||
derivation-ids-hash-table
|
||||
#:skip-system-tests?
|
||||
skip-system-tests?
|
||||
|
|
@ -2619,6 +2638,9 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
|
|||
#:parallelism parallelism)
|
||||
(let ((guix-revision-id
|
||||
(fibers-force guix-revision-id-promise)))
|
||||
(destroy-parallelism-limiter
|
||||
read-derivations/parallelism-limiter)
|
||||
|
||||
(and
|
||||
(if (defined? 'channel-news-for-commit
|
||||
(resolve-module '(guix channels)))
|
||||
|
|
@ -3133,7 +3155,9 @@ SKIP LOCKED")
|
|||
#:parallelism parallelism))
|
||||
|
||||
(record-job-succeeded conn id)
|
||||
(record-job-event conn id "success"))
|
||||
(record-job-event conn id "success")
|
||||
|
||||
#t)
|
||||
(()
|
||||
(raise-exception
|
||||
job-not-found-exception))))))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue