From a0dd2982393fccdb6e04d16d701c8c44235d0b54 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 13 Mar 2019 09:24:47 +0000 Subject: [PATCH] Hopefully speed up the new guix revision processing Compute all derivations at once in the inferior, avoiding round trips to hopefully speed it up. Close the inferior earlier to free up memory, and add more debugging output. --- .../jobs/load-new-guix-revision.scm | 201 +++++++++--------- 1 file changed, 105 insertions(+), 96 deletions(-) diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm index 23044ec..6b54147 100644 --- a/guix-data-service/jobs/load-new-guix-revision.scm +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -1,6 +1,7 @@ (define-module (guix-data-service jobs load-new-guix-revision) #:use-module (srfi srfi-1) #:use-module (ice-9 match) + #:use-module (ice-9 hash-table) #:use-module (squee) #:use-module (guix monads) #:use-module (guix store) @@ -21,85 +22,85 @@ select-job-for-commit most-recent-n-load-new-guix-revision-jobs)) -(define (inferior-guix->package-derivation-ids store conn inf) - (define (inferior-package->systems-targets-and-derivations package) - (let ((supported-systems - (inferior-package-transitive-supported-systems package))) - (append-map - (lambda (system) - (filter-map - (lambda (target) - (catch - #t - (lambda () - (list - system - target - (inferior-package-derivation store package system - #:target - (if (string=? system target) - #f - target)))) - (lambda args - (cond - ((string-contains (simple-format #f "~A" (second args)) - "&package-cross-build-system-error") - #f) - ((string-contains (simple-format #f "~A" (fourth args)) - "(No cross-compilation for ") - #f) - (else - (simple-format - #t "guix-data-service: inferior-guix->package-ids: error processing derivation\n ~A for system ~A and target ~A\n" - package system target) - (for-each (lambda (arg) - (simple-format #t "arg: ~A\n" arg)) - args) - #f))))) - supported-systems)) - supported-systems))) +(define inferior-package-id + (@@ (guix inferior) inferior-package-id)) +(define (all-inferior-package-derivations store inf packages) + (define proc + `(lambda (store) + (append-map + (lambda (inferior-package-id) + (let* ((package + (hashv-ref %package-table inferior-package-id)) + (supported-systems + (package-transitive-supported-systems package))) + (append-map + (lambda (system) + (filter-map + (lambda (target) + (catch + 'misc-error + (lambda () + (guard (c ((package-cross-build-system-error? c) + #f)) + (list inferior-package-id + system + target + (derivation-file-name + (if (string=? system target) + (package-derivation store package system) + (package-cross-derivation store package + target + system)))))) + (lambda args + #f))) + supported-systems)) + supported-systems))) + (list ,@(map inferior-package-id packages))))) + + (inferior-eval-with-store inf store proc)) + +(define (inferior-guix->package-derivation-ids store conn inf) (let* ((packages (inferior-packages inf)) (packages-metadata-ids (inferior-packages->package-metadata-ids conn packages)) - (packages-count (length packages)) - (progress-reporter (progress-reporter/bar - packages-count - (format #f "processing ~a packages" - packages-count))) - (systems-targets-and-derivations-by-package - (call-with-progress-reporter progress-reporter - (lambda (report) - (map - (lambda (package) - (report) - (inferior-package->systems-targets-and-derivations package)) - packages)))) (package-ids (inferior-packages->package-ids conn packages packages-metadata-ids)) - (derivation-ids - (derivations->derivation-ids - conn - (append-map - (lambda (system-targets-and-derivations) - (map third system-targets-and-derivations)) - systems-targets-and-derivations-by-package))) - (flat-package-ids-systems-and-targets - (append-map - (lambda (package-id system-targets-and-derivations) - (map (match-lambda - ((system target derivation) - (list package-id - system - target))) - system-targets-and-derivations)) - package-ids - systems-targets-and-derivations-by-package))) + (inferior-package-id->package-id-hash-table + (alist->hashq-table + (map (lambda (package package-id) + (cons (inferior-package-id package) + package-id)) + packages + package-ids))) + (inferior-data-4-tuples + (all-inferior-package-derivations store inf packages))) - (insert-package-derivations conn - flat-package-ids-systems-and-targets - derivation-ids))) + (simple-format + #t "debug: finished loading information from inferior\n") + (close-inferior inf) + + (let ((derivation-ids + (derivations->derivation-ids + conn + (map (lambda (tuple) + (read-derivation-from-file + (fourth tuple))) + inferior-data-4-tuples))) + (flat-package-ids-systems-and-targets + (map + (match-lambda + ((inferior-package-id system target derivation-file-name) + (list (hashq-ref inferior-package-id->package-id-hash-table + inferior-package-id) + system + target))) + inferior-data-4-tuples))) + + (insert-package-derivations conn + flat-package-ids-systems-and-targets + derivation-ids)))) (define (inferior-package-transitive-supported-systems package) ((@@ (guix inferior) inferior-package-field) @@ -154,24 +155,29 @@ (@@ (guix channels) channel-instance)) inferior) - (inferior-eval-with-store - inferior - store - `(lambda (store) - (let ((instances - (list - (channel-instance - (channel (name ',(channel-name channel)) - (url ,(channel-url channel)) - (branch ,(channel-branch channel)) - (commit ,(channel-commit channel))) - ,(channel-instance-commit channel-instance) - ,(channel-instance-checkout channel-instance))))) - (run-with-store store - (mlet* %store-monad ((manifest (channel-instances->manifest instances)) - (derv (profile-derivation manifest))) - (mbegin %store-monad - (return (derivation-file-name derv))))))))))) + (let ((file-name + (inferior-eval-with-store + inferior + store + `(lambda (store) + (let ((instances + (list + (channel-instance + (channel (name ',(channel-name channel)) + (url ,(channel-url channel)) + (branch ,(channel-branch channel)) + (commit ,(channel-commit channel))) + ,(channel-instance-commit channel-instance) + ,(channel-instance-checkout channel-instance))))) + (run-with-store store + (mlet* %store-monad ((manifest (channel-instances->manifest instances)) + (derv (profile-derivation manifest))) + (mbegin %store-monad + (return (derivation-file-name derv)))))))))) + + (close-inferior inferior) + + file-name)))) (define (channel->manifest-store-item store channel) (let* ((manifest-store-item-derivation-file-name @@ -194,18 +200,23 @@ (simple-format #t "guix-data-service: load-new-guix-revision: error: ~A\n" args) #f))) -(define (extract-information-from store conn url commit store_path) - (let ((inf (open-inferior/container store store_path +(define (extract-information-from store conn url commit store-path) + (simple-format + #t "debug: extract-information-from: ~A\n" store-path) + (let ((inf (open-inferior/container store store-path #:extra-shared-directories '("/gnu/store")))) - (inferior-eval '(use-modules (guix grafts)) inf) + (inferior-eval '(use-modules (srfi srfi-1) + (srfi srfi-34) + (guix grafts)) + inf) (inferior-eval '(%graft? #f) inf) (exec-query conn "BEGIN") (let ((package-derivation-ids (inferior-guix->package-derivation-ids store conn inf)) (guix-revision-id - (insert-guix-revision conn url commit store_path))) + (insert-guix-revision conn url commit store-path))) (insert-guix-revision-package-derivations conn guix-revision-id @@ -215,9 +226,7 @@ (simple-format #t "Successfully loaded ~A package/derivation pairs\n" - (length package-derivation-ids))) - - (close-inferior inf))) + (length package-derivation-ids))))) (define (load-new-guix-revision conn url commit) (if (guix-revision-exists? conn url commit)