cbaines pushed a commit to branch master
in repository data-service.
commit 7df7fd3e5269e6106ee879c42c94c4805746c151
Author: Christopher Baines <[email protected]>
AuthorDate: Fri Jul 19 19:45:07 2024 +0100
Compute package derivations in chunks
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.
---
guix-data-service/jobs/load-new-guix-revision.scm | 205 +++++++++++++---------
1 file changed, 124 insertions(+), 81 deletions(-)
diff --git a/guix-data-service/jobs/load-new-guix-revision.scm
b/guix-data-service/jobs/load-new-guix-revision.scm
index dd52c73..ebd067a 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -405,7 +405,7 @@
(append supported-system-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
`(lambda (store)
(define system-target-pair
@@ -511,63 +511,68 @@
(/ (assoc-ref stats 'heap-size)
(expt 2. 20)))))
- (vector-map
- (lambda (_ package)
- (catch
- #t
- (lambda ()
- (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")
- (simple-format
- (current-error-port)
- "looking at guix package (supported systems: ~A, system
supported: ~A, target supported: ~A\n"
- supported-systems
- system-supported?
- target-supported?))
-
- (if system-supported?
- (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
- (current-error-port)
- "error: while processing ~A, exiting: ~A: ~A\n"
- (package-name package)
- key
- args)
- (exit 1))
- (begin
+ (let ((vec (list->vector
+ (iota ,count ,start-index))))
+ (vector-map!
+ (lambda (_ index)
+ (define package (vector-ref gds-inferior-packages index))
+
+ (catch
+ #t
+ (lambda ()
+ (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")
(simple-format
(current-error-port)
- "error: while processing ~A ignoring error: ~A: ~A\n"
- (package-name package)
- key
- args)
- #f)))))
- gds-inferior-packages)))
+ "looking at guix package (supported systems: ~A, system
supported: ~A, target supported: ~A\n"
+ supported-systems
+ system-supported?
+ target-supported?))
+
+ (if system-supported?
+ (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
+ (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
'(when (defined? 'systems (resolve-module '(guix platform)))
@@ -1449,21 +1454,25 @@
1
#: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
(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))))))))
+ (let ((packages-data (fibers-force packages-data-promise)))
(with-resource-from-pool postgresql-connection-pool conn
(insert-packages conn packages-data))))))
@@ -1524,6 +1533,13 @@
lint-warning-ids)))))))
(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
(match-lambda
((system . target)
@@ -1535,19 +1551,46 @@
(sleep 30)
(loop (stat:size (stat "/var/guix/db/db.sqlite-wal")))))
- (let ((derivations-vector
- (with-resource-from-pool inf-and-store-pool res
- (with-time-logging
- (simple-format #f "getting derivations for ~A" (cons
system target))
- (match res
- ((inferior . inferior-store)
- (ensure-gds-inferior-packages-defined! inferior)
-
- (inferior-package-derivations
- inferior-store
- inferior
- 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))
+ (if (>= (+ start-index chunk-size) packages-count)
+ (let* ((remaining-count
+ (- 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-store
+ inferior
+ system
+ 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)))
(with-resource-from-pool postgresql-connection-pool conn
