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

Compute package derivations in chunks

Browse source 
This allows for keeping the inferiors and store connections around for a more
constant period, and allows closing the store connections and allowing the
guix-daemon to clear the WAL file if needed.
This commit is contained in:
Christopher Baines 2024-07-19 19:45:07 +01:00
parent ed4ba8eb95
commit 7df7fd3e52
1 changed files with 121 additions and 78 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -405,7 +405,7 @@
(append supported-system-pairs (append supported-system-pairs
supported-system-cross-build-pairs)) supported-system-cross-build-pairs))
(define (inferior-package-derivations store inf system target) (define (inferior-package-derivations store inf system target start-index count)
(define proc (define proc
`(lambda (store) `(lambda (store)
(define system-target-pair (define system-target-pair
@ -511,63 +511,68 @@
(/ (assoc-ref stats 'heap-size) (/ (assoc-ref stats 'heap-size)
(expt 2. 20))))) (expt 2. 20)))))
(vector-map (let ((vec (list->vector
(lambda (_ package) (iota ,count ,start-index))))
(catch (vector-map!
#t (lambda (_ index)
(lambda () (define package (vector-ref gds-inferior-packages index))
(let* ((system (car system-target-pair))
(target (cdr system-target-pair))
(supported-systems (get-supported-systems package system))
(system-supported?
(and supported-systems
(->bool (member system supported-systems))))
(target-supported?
(or (not target)
(let ((system-for-target
(assoc-ref target-system-alist
target)))
(or (not system-for-target)
(->bool
(member system-for-target
(package-supported-systems package)
string=?)))))))
(when (string=? (package-name package) "guix") (catch
(simple-format #t
(current-error-port) (lambda ()
"looking at guix package (supported systems: ~A, system supported: ~A, target supported: ~A\n" (let* ((system (car system-target-pair))
supported-systems (target (cdr system-target-pair))
system-supported? (supported-systems (get-supported-systems package system))
target-supported?)) (system-supported?
(and supported-systems
(->bool (member system supported-systems))))
(target-supported?
(or (not target)
(let ((system-for-target
(assoc-ref target-system-alist
target)))
(or (not system-for-target)
(->bool
(member system-for-target
(package-supported-systems package)
string=?)))))))
(if system-supported? (when (string=? (package-name package) "guix")
(if target-supported?
(derivation-for-system-and-target package
system
target)
#f)
#f)))
(lambda (key . args)
(if (and (eq? key 'system-error)
(eq? (car args) 'fport_write))
(begin
(simple-format (simple-format
(current-error-port) (current-error-port)
"error: while processing ~A, exiting: ~A: ~A\n" "looking at guix package (supported systems: ~A, system supported: ~A, target supported: ~A\n"
(package-name package) supported-systems
key system-supported?
args) target-supported?))
(exit 1))
(begin (if system-supported?
(simple-format (if target-supported?
(current-error-port) (derivation-for-system-and-target package
"error: while processing ~A ignoring error: ~A: ~A\n" system
(package-name package) target)
key #f)
args) #f)))
#f))))) (lambda (key . args)
gds-inferior-packages))) (if (and (eq? key 'system-error)
(eq? (car args) 'fport_write))
(begin
(simple-format
(current-error-port)
"error: while processing ~A, exiting: ~A: ~A\n"
(package-name package)
key
args)
(exit 1))
(begin
(simple-format
(current-error-port)
"error: while processing ~A ignoring error: ~A: ~A\n"
(package-name package)
key
args)
#f)))))
vec)
vec)))
(inferior-eval (inferior-eval
'(when (defined? 'systems (resolve-module '(guix platform))) '(when (defined? 'systems (resolve-module '(guix platform)))
@ -1449,21 +1454,25 @@
1 1
#:min-size 0)) #:min-size 0))
(define packages-data-promise
(fibers-delay
(lambda ()
(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)))))))))
(define package-ids-promise (define package-ids-promise
(fibers-delay (fibers-delay
(lambda () (lambda ()
(let ((packages-data (let ((packages-data (fibers-force packages-data-promise)))
(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))))))))
(with-resource-from-pool postgresql-connection-pool conn (with-resource-from-pool postgresql-connection-pool conn
(insert-packages conn packages-data)))))) (insert-packages conn packages-data))))))
@ -1524,6 +1533,13 @@
lint-warning-ids))))))) lint-warning-ids)))))))
(define (extract-and-store-package-derivations) (define (extract-and-store-package-derivations)
(define packages-count
(vector-length
(assq-ref (fibers-force packages-data-promise)
'names)))
(define chunk-size 3000)
(fibers-for-each (fibers-for-each
(match-lambda (match-lambda
((system . target) ((system . target)
@ -1535,19 +1551,46 @@
(sleep 30) (sleep 30)
(loop (stat:size (stat "/var/guix/db/db.sqlite-wal"))))) (loop (stat:size (stat "/var/guix/db/db.sqlite-wal")))))
(let ((derivations-vector (let ((derivations-vector (make-vector packages-count)))
(with-resource-from-pool inf-and-store-pool res (with-time-logging
(with-time-logging (simple-format #f "getting derivations for ~A" (cons system target))
(simple-format #f "getting derivations for ~A" (cons system target)) (let loop ((start-index 0))
(match res (if (>= (+ start-index chunk-size) packages-count)
((inferior . inferior-store) (let* ((remaining-count
(ensure-gds-inferior-packages-defined! inferior) (- packages-count start-index))
(chunk
(with-resource-from-pool inf-and-store-pool res
(match res
((inferior . inferior-store)
(ensure-gds-inferior-packages-defined! inferior)
(inferior-package-derivations (inferior-package-derivations
inferior-store inferior-store
inferior inferior
system system
target))))))) target
start-index
remaining-count))))))
(vector-copy! derivations-vector
start-index
chunk))
(let ((chunk
(with-resource-from-pool inf-and-store-pool res
(match res
((inferior . inferior-store)
(ensure-gds-inferior-packages-defined! inferior)
(inferior-package-derivations
inferior-store
inferior
system
target
start-index
chunk-size))))))
(vector-copy! derivations-vector
start-index
chunk)
(loop (+ start-index chunk-size))))))
(let ((package-ids (fibers-force package-ids-promise))) (let ((package-ids (fibers-force package-ids-promise)))
(with-resource-from-pool postgresql-connection-pool conn (with-resource-from-pool postgresql-connection-pool conn