From 76cc8d82b9147f8925e84294f374ec5386e7835b Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 27 Jun 2025 10:39:41 +0200 Subject: [PATCH] Only compute derivations if there are any to fix --- .../jobs/load-new-guix-revision.scm | 343 +++++++++--------- 1 file changed, 172 insertions(+), 171 deletions(-) diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm index b1f2d13..9a81c9c 100644 --- a/guix-data-service/jobs/load-new-guix-revision.scm +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -1530,186 +1530,187 @@ WHERE builder != 'builtin:download' #:ignore-targets ignore-targets))) (simple-format #t "~A broken derivations\n" (length broken-derivations)) - (run-fibers - (lambda () - (with-exception-handler - (lambda (exn) - (print-backtrace-and-exception/knots exn) - (raise-exception exn)) - (lambda () - (let* ((guix-source - channel-derivations-by-system - (with-postgresql-connection - "channel->source-and-derivations-by-system" - (lambda (conn) - (let* ((git-repository-fields - (select-git-repository conn git-repository-id)) - (git-repository-url - (assq-ref git-repository-fields 'url)) - (fetch-with-authentication? - (assq-ref git-repository-fields 'fetch-with-authentication?))) - (channel->source-and-derivations-by-system - conn - (channel (name 'guix) - (url git-repository-url) - (commit commit)) - fetch-with-authentication? - #:parallelism parallelism - #:ignore-systems ignore-systems))))) - (store-item - guix-derivation - (channel-derivations-by-system->guix-store-item - channel-derivations-by-system)) - (guix-locpath - ;; Augment the GUIX_LOCPATH to include glibc-locales from - ;; the Guix at store-path, this should mean that the - ;; inferior Guix works, even if it's build using a different - ;; glibc version - (string-append - (with-store-connection - (lambda (store) - (glibc-locales-for-guix-store-path store store-item))) - "/lib/locale" - ":" (getenv "GUIX_LOCPATH")))) + (unless (= 0 broken-derivations) + (run-fibers + (lambda () + (with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) + (lambda () + (let* ((guix-source + channel-derivations-by-system + (with-postgresql-connection + "channel->source-and-derivations-by-system" + (lambda (conn) + (let* ((git-repository-fields + (select-git-repository conn git-repository-id)) + (git-repository-url + (assq-ref git-repository-fields 'url)) + (fetch-with-authentication? + (assq-ref git-repository-fields 'fetch-with-authentication?))) + (channel->source-and-derivations-by-system + conn + (channel (name 'guix) + (url git-repository-url) + (commit commit)) + fetch-with-authentication? + #:parallelism parallelism + #:ignore-systems ignore-systems))))) + (store-item + guix-derivation + (channel-derivations-by-system->guix-store-item + channel-derivations-by-system)) + (guix-locpath + ;; Augment the GUIX_LOCPATH to include glibc-locales from + ;; the Guix at store-path, this should mean that the + ;; inferior Guix works, even if it's build using a different + ;; glibc version + (string-append + (with-store-connection + (lambda (store) + (glibc-locales-for-guix-store-path store store-item))) + "/lib/locale" + ":" (getenv "GUIX_LOCPATH")))) - (define inf-and-store-pool - (make-resource-pool - (lambda () - (let* ((inferior-store (open-store-connection))) - (unless (valid-path? inferior-store store-item) - (simple-format #t "warning: store item missing (~A)\n" - store-item) - (simple-format #t "warning: building (~A)\n" - guix-derivation) - (build-derivations inferior-store - (list (read-derivation-from-file - guix-derivation)))) - ;; Use this more to keep the store-path alive so long as there's a - ;; inferior operating - (add-temp-root inferior-store store-item) + (define inf-and-store-pool + (make-resource-pool + (lambda () + (let* ((inferior-store (open-store-connection))) + (unless (valid-path? inferior-store store-item) + (simple-format #t "warning: store item missing (~A)\n" + store-item) + (simple-format #t "warning: building (~A)\n" + guix-derivation) + (build-derivations inferior-store + (list (read-derivation-from-file + guix-derivation)))) + ;; Use this more to keep the store-path alive so long as there's a + ;; inferior operating + (add-temp-root inferior-store store-item) - (let ((inferior (start-inferior-for-data-extration - inferior-store - store-item - guix-locpath - extra-inferior-environment-variables))) - (ensure-non-blocking-store-connection inferior-store) - (make-inferior-non-blocking! inferior) - (simple-format #t "debug: started new inferior and store connection\n") - - (cons inferior inferior-store)))) - parallelism - #:min-size 0 - #:idle-seconds 20 - #:name "inferior" - #:destructor - (match-lambda - ((inferior . store) - (simple-format - #t "debug: closing inferior and associated store connection\n") - - (close-connection store) - (close-inferior inferior))))) - - (define packages-count - (call-with-inferior - inf-and-store-pool - (lambda (inferior inferior-store) - (ensure-gds-inferior-packages-defined! inferior) - - (inferior-eval '(vector-length gds-inferior-packages) inferior)) - #:memory-limit inferior-memory-limit)) - - (define chunk-size 1000) - - (define compute-derivations/parallelism-limiter - (make-parallelism-limiter parallelism)) - (define (compute-derivations system target) - ;; Limit concurrency here to keep focused on specific systems until - ;; they've been fully processed - (with-parallelism-limiter - compute-derivations/parallelism-limiter - (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 - inf-and-store-pool - (lambda (inferior inferior-store) - (ensure-gds-inferior-packages-defined! inferior) - - (let ((result - (inferior-package-derivations + (let ((inferior (start-inferior-for-data-extration inferior-store - inferior - system - target - start-index - count))) + store-item + guix-locpath + extra-inferior-environment-variables))) + (ensure-non-blocking-store-connection inferior-store) + (make-inferior-non-blocking! inferior) + (simple-format #t "debug: started new inferior and store connection\n") - (when last-chunk? - (inferior-cleanup inferior)) + (cons inferior inferior-store)))) + parallelism + #:min-size 0 + #:idle-seconds 20 + #:name "inferior" + #:destructor + (match-lambda + ((inferior . store) + (simple-format + #t "debug: closing inferior and associated store connection\n") - result)) - #:memory-limit inferior-memory-limit))) - (unless last-chunk? - (loop (+ start-index chunk-size)))))))) + (close-connection store) + (close-inferior inferior))))) - (with-time-logging "compute package derivations" - (fibers-map-with-progress - (match-lambda - ((system . target) - (compute-derivations system target))) - (list - (let ((all-system-target-pairs - (call-with-inferior - inf-and-store-pool - (lambda (inferior inferior-store) - (inferior-fetch-system-target-pairs inferior)) - #:memory-limit inferior-memory-limit))) - (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)))) + (define packages-count + (call-with-inferior + inf-and-store-pool + (lambda (inferior inferior-store) + (ensure-gds-inferior-packages-defined! inferior) - (destroy-resource-pool - inf-and-store-pool) - (destroy-parallelism-limiter - compute-derivations/parallelism-limiter))))) - #:hz 0 - #:parallelism 1 - #:drain? #t) + (inferior-eval '(vector-length gds-inferior-packages) inferior)) + #:memory-limit inferior-memory-limit)) - (simple-format #t "fixing ~A derivations\n" - (length broken-derivations)) + (define chunk-size 1000) - (for-each fix-derivation - broken-derivations))) + (define compute-derivations/parallelism-limiter + (make-parallelism-limiter parallelism)) + (define (compute-derivations system target) + ;; Limit concurrency here to keep focused on specific systems until + ;; they've been fully processed + (with-parallelism-limiter + compute-derivations/parallelism-limiter + (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 + inf-and-store-pool + (lambda (inferior inferior-store) + (ensure-gds-inferior-packages-defined! inferior) + + (let ((result + (inferior-package-derivations + inferior-store + inferior + system + target + start-index + count))) + + (when last-chunk? + (inferior-cleanup inferior)) + + result)) + #:memory-limit inferior-memory-limit))) + (unless last-chunk? + (loop (+ start-index chunk-size)))))))) + + (with-time-logging "compute package derivations" + (fibers-map-with-progress + (match-lambda + ((system . target) + (compute-derivations system target))) + (list + (let ((all-system-target-pairs + (call-with-inferior + inf-and-store-pool + (lambda (inferior inferior-store) + (inferior-fetch-system-target-pairs inferior)) + #:memory-limit inferior-memory-limit))) + (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-resource-pool + inf-and-store-pool) + (destroy-parallelism-limiter + compute-derivations/parallelism-limiter))))) + #:hz 0 + #:parallelism 1 + #:drain? #t) + + (simple-format #t "fixing ~A derivations\n" + (length broken-derivations)) + + (for-each fix-derivation + broken-derivations)))) (define* (derivation-file-names->derivation-ids postgresql-connection-pool call-with-utility-thread