mirror of
git://git.savannah.gnu.org/guix/data-service.git
synced 2023-12-14 03:23:03 +01:00
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.
This commit is contained in:
parent
e117bb1d87
commit
a0dd298239
|
@ -1,6 +1,7 @@
|
||||||
(define-module (guix-data-service jobs load-new-guix-revision)
|
(define-module (guix-data-service jobs load-new-guix-revision)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
|
#:use-module (ice-9 hash-table)
|
||||||
#:use-module (squee)
|
#:use-module (squee)
|
||||||
#:use-module (guix monads)
|
#:use-module (guix monads)
|
||||||
#:use-module (guix store)
|
#:use-module (guix store)
|
||||||
|
@ -21,85 +22,85 @@
|
||||||
select-job-for-commit
|
select-job-for-commit
|
||||||
most-recent-n-load-new-guix-revision-jobs))
|
most-recent-n-load-new-guix-revision-jobs))
|
||||||
|
|
||||||
(define (inferior-guix->package-derivation-ids store conn inf)
|
(define inferior-package-id
|
||||||
(define (inferior-package->systems-targets-and-derivations package)
|
(@@ (guix inferior) inferior-package-id))
|
||||||
(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 (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))
|
(let* ((packages (inferior-packages inf))
|
||||||
(packages-metadata-ids
|
(packages-metadata-ids
|
||||||
(inferior-packages->package-metadata-ids conn packages))
|
(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
|
(package-ids
|
||||||
(inferior-packages->package-ids
|
(inferior-packages->package-ids
|
||||||
conn packages packages-metadata-ids))
|
conn packages packages-metadata-ids))
|
||||||
(derivation-ids
|
(inferior-package-id->package-id-hash-table
|
||||||
(derivations->derivation-ids
|
(alist->hashq-table
|
||||||
conn
|
(map (lambda (package package-id)
|
||||||
(append-map
|
(cons (inferior-package-id package)
|
||||||
(lambda (system-targets-and-derivations)
|
package-id))
|
||||||
(map third system-targets-and-derivations))
|
packages
|
||||||
systems-targets-and-derivations-by-package)))
|
package-ids)))
|
||||||
(flat-package-ids-systems-and-targets
|
(inferior-data-4-tuples
|
||||||
(append-map
|
(all-inferior-package-derivations store inf packages)))
|
||||||
(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)))
|
|
||||||
|
|
||||||
(insert-package-derivations conn
|
(simple-format
|
||||||
flat-package-ids-systems-and-targets
|
#t "debug: finished loading information from inferior\n")
|
||||||
derivation-ids)))
|
(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)
|
(define (inferior-package-transitive-supported-systems package)
|
||||||
((@@ (guix inferior) inferior-package-field)
|
((@@ (guix inferior) inferior-package-field)
|
||||||
|
@ -154,24 +155,29 @@
|
||||||
(@@ (guix channels) channel-instance))
|
(@@ (guix channels) channel-instance))
|
||||||
inferior)
|
inferior)
|
||||||
|
|
||||||
(inferior-eval-with-store
|
(let ((file-name
|
||||||
inferior
|
(inferior-eval-with-store
|
||||||
store
|
inferior
|
||||||
`(lambda (store)
|
store
|
||||||
(let ((instances
|
`(lambda (store)
|
||||||
(list
|
(let ((instances
|
||||||
(channel-instance
|
(list
|
||||||
(channel (name ',(channel-name channel))
|
(channel-instance
|
||||||
(url ,(channel-url channel))
|
(channel (name ',(channel-name channel))
|
||||||
(branch ,(channel-branch channel))
|
(url ,(channel-url channel))
|
||||||
(commit ,(channel-commit channel)))
|
(branch ,(channel-branch channel))
|
||||||
,(channel-instance-commit channel-instance)
|
(commit ,(channel-commit channel)))
|
||||||
,(channel-instance-checkout channel-instance)))))
|
,(channel-instance-commit channel-instance)
|
||||||
(run-with-store store
|
,(channel-instance-checkout channel-instance)))))
|
||||||
(mlet* %store-monad ((manifest (channel-instances->manifest instances))
|
(run-with-store store
|
||||||
(derv (profile-derivation manifest)))
|
(mlet* %store-monad ((manifest (channel-instances->manifest instances))
|
||||||
(mbegin %store-monad
|
(derv (profile-derivation manifest)))
|
||||||
(return (derivation-file-name derv)))))))))))
|
(mbegin %store-monad
|
||||||
|
(return (derivation-file-name derv))))))))))
|
||||||
|
|
||||||
|
(close-inferior inferior)
|
||||||
|
|
||||||
|
file-name))))
|
||||||
|
|
||||||
(define (channel->manifest-store-item store channel)
|
(define (channel->manifest-store-item store channel)
|
||||||
(let* ((manifest-store-item-derivation-file-name
|
(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)
|
(simple-format #t "guix-data-service: load-new-guix-revision: error: ~A\n" args)
|
||||||
#f)))
|
#f)))
|
||||||
|
|
||||||
(define (extract-information-from store conn url commit store_path)
|
(define (extract-information-from store conn url commit store-path)
|
||||||
(let ((inf (open-inferior/container store store_path
|
(simple-format
|
||||||
|
#t "debug: extract-information-from: ~A\n" store-path)
|
||||||
|
(let ((inf (open-inferior/container store store-path
|
||||||
#:extra-shared-directories
|
#:extra-shared-directories
|
||||||
'("/gnu/store"))))
|
'("/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)
|
(inferior-eval '(%graft? #f) inf)
|
||||||
|
|
||||||
(exec-query conn "BEGIN")
|
(exec-query conn "BEGIN")
|
||||||
(let ((package-derivation-ids
|
(let ((package-derivation-ids
|
||||||
(inferior-guix->package-derivation-ids store conn inf))
|
(inferior-guix->package-derivation-ids store conn inf))
|
||||||
(guix-revision-id
|
(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
|
(insert-guix-revision-package-derivations conn
|
||||||
guix-revision-id
|
guix-revision-id
|
||||||
|
@ -215,9 +226,7 @@
|
||||||
|
|
||||||
(simple-format
|
(simple-format
|
||||||
#t "Successfully loaded ~A package/derivation pairs\n"
|
#t "Successfully loaded ~A package/derivation pairs\n"
|
||||||
(length package-derivation-ids)))
|
(length package-derivation-ids)))))
|
||||||
|
|
||||||
(close-inferior inf)))
|
|
||||||
|
|
||||||
(define (load-new-guix-revision conn url commit)
|
(define (load-new-guix-revision conn url commit)
|
||||||
(if (guix-revision-exists? conn url commit)
|
(if (guix-revision-exists? conn url commit)
|
||||||
|
|
Loading…
Reference in a new issue