From 7df7fd3e5269e6106ee879c42c94c4805746c151 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 19 Jul 2024 19:45:07 +0100 Subject: [PATCH] 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. --- .../jobs/load-new-guix-revision.scm | 199 +++++++++++------- 1 file changed, 121 insertions(+), 78 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=?))))))) + (let ((vec (list->vector + (iota ,count ,start-index)))) + (vector-map! + (lambda (_ index) + (define package (vector-ref gds-inferior-packages index)) - (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?)) + (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=?))))))) - (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 + (when (string=? (package-name package) "guix") (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))))) - 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) + (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))))))) + (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