cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Further improve load-new-guix-revision-jobs

Browse source 
Split the derivations up in to some groups, and run
invalidate-derivation-caches! inbetween to try and reduce the memory
usage.

Also make a couple of other changes to reduce memory usage or protect
against errors.
This commit is contained in:
Christopher Baines 2019-03-16 17:26:44 +00:00
parent 9f162c3b2c
commit a092db5007
Signed by: cbaines
GPG key ID: 5E28A33B0B84F577
2 changed files with 101 additions and 53 deletions
Download patch file Download diff file Expand all files Collapse all files

10
guix-data-service/jobs.scm
View file

@ -4,8 +4,8 @@
#:export (process-jobs)) #:export (process-jobs))
(define (process-jobs conn) (define (process-jobs conn)
(match (process-next-load-new-guix-revision-job conn) (while #t
(#f (begin (simple-format #t "Waiting for new jobs...") (match (process-next-load-new-guix-revision-job conn)
(sleep 60) (#f (begin (simple-format #t "Waiting for new jobs...")
(process-jobs conn))) (sleep 60)))
(_ (process-jobs conn)))) (_ #f))))

144
guix-data-service/jobs/load-new-guix-revision.scm
View file

@ -37,7 +37,23 @@
result)) result))
(define (all-inferior-package-derivations store inf packages) (define (all-inferior-package-derivations store inf packages)
(define proc (define inferior-%supported-systems
(inferior-eval '(@ (guix packages) %supported-systems) inf))
(define supported-system-pairs
(map (lambda (system)
(cons system system))
inferior-%supported-systems))
(define supported-system-cross-build-pairs
(map (lambda (system)
(filter-map (lambda (target)
(and (not (string=? system target))
(cons system target)))
inferior-%supported-systems))
inferior-%supported-systems))
(define (proc packages system-target-pairs)
`(lambda (store) `(lambda (store)
(append-map (append-map
(lambda (inferior-package-id) (lambda (inferior-package-id)
@ -66,10 +82,18 @@
target target
system)))))) system))))))
(lambda args (lambda args
;; misc-error #f ~A ~S (No cross-compilation for clojure-build-system yet: ;; misc-error #f ~A ~S (No
;; cross-compilation for
;; clojure-build-system yet:
#f))) #f)))
supported-systems)) (lset-intersection
supported-systems))) string=?
supported-systems
(list ,@(map cdr system-target-pairs)))))
(lset-intersection
string=?
supported-systems
(list ,@(map car system-target-pairs))))))
(lambda args (lambda args
(simple-format (current-error-port) (simple-format (current-error-port)
"error: while processing ~A ignoring error: ~A\n" "error: while processing ~A ignoring error: ~A\n"
@ -78,7 +102,20 @@
'())))) '()))))
(list ,@(map inferior-package-id packages))))) (list ,@(map inferior-package-id packages)))))
(inferior-eval-with-store inf store proc)) (append-map
(lambda (system-target-pairs)
(format (current-error-port)
"heap size: ~a MiB~%"
(round
(/ (assoc-ref (gc-stats) 'heap-size)
(expt 2. 20))))
(log-time
(simple-format #f "getting derivations for ~A" system-target-pairs)
(lambda ()
(inferior-eval '(invalidate-derivation-caches!) inf)
(inferior-eval-with-store inf store (proc packages system-target-pairs)))))
(append (map list supported-system-pairs)
supported-system-cross-build-pairs)))
(define (inferior-guix->package-derivation-ids store conn inf) (define (inferior-guix->package-derivation-ids store conn inf)
(let* ((packages (log-time "fetching inferior packages" (let* ((packages (log-time "fetching inferior packages"
@ -157,52 +194,63 @@
(list (string-append (list (string-append
"SSL_CERT_DIR=" (nss-certs-store-path store)))))) "SSL_CERT_DIR=" (nss-certs-store-path store))))))
;; Create /etc/pass, as %known-shorthand-profiles in (guix (catch
;; profiles) tries to read from this file. Because the environment #t
;; is cleaned in build-self.scm, xdg-directory in (guix utils) (lambda ()
;; falls back to accessing /etc/passwd. ;; Create /etc/pass, as %known-shorthand-profiles in (guix
(inferior-eval ;; profiles) tries to read from this file. Because the environment
'(begin ;; is cleaned in build-self.scm, xdg-directory in (guix utils)
(mkdir "/etc") ;; falls back to accessing /etc/passwd.
(call-with-output-file "/etc/passwd" (inferior-eval
(lambda (port) '(begin
(display "root:x:0:0::/root:/bin/bash" port)))) (mkdir "/etc")
inferior) (call-with-output-file "/etc/passwd"
(lambda (port)
(display "root:x:0:0::/root:/bin/bash" port))))
inferior)
(let ((channel-instance (let ((channel-instance
(first (first
(latest-channel-instances store (latest-channel-instances store
(list channel))))) (list channel)))))
(inferior-eval '(use-modules (guix channels) (inferior-eval '(use-modules (guix channels)
(guix profiles)) (guix profiles))
inferior) inferior)
(inferior-eval '(define channel-instance (inferior-eval '(define channel-instance
(@@ (guix channels) channel-instance)) (@@ (guix channels) channel-instance))
inferior) inferior)
(let ((file-name (let ((file-name
(inferior-eval-with-store (inferior-eval-with-store
inferior inferior
store store
`(lambda (store) `(lambda (store)
(let ((instances (let ((instances
(list (list
(channel-instance (channel-instance
(channel (name ',(channel-name channel)) (channel (name ',(channel-name channel))
(url ,(channel-url channel)) (url ,(channel-url channel))
(branch ,(channel-branch channel)) (branch ,(channel-branch channel))
(commit ,(channel-commit channel))) (commit ,(channel-commit channel)))
,(channel-instance-commit channel-instance) ,(channel-instance-commit channel-instance)
,(channel-instance-checkout channel-instance))))) ,(channel-instance-checkout channel-instance)))))
(run-with-store store (run-with-store store
(mlet* %store-monad ((manifest (channel-instances->manifest instances)) (mlet* %store-monad ((manifest (channel-instances->manifest instances))
(derv (profile-derivation manifest))) (derv (profile-derivation manifest)))
(mbegin %store-monad (mbegin %store-monad
(return (derivation-file-name derv)))))))))) (return (derivation-file-name derv))))))))))
(close-inferior inferior)
file-name)))
(lambda args
(simple-format (current-error-port)
"error: channel->derivation-file-name: ~A\n"
args)
(close-inferior inferior) (close-inferior inferior)
file-name)))) #f))))
(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
@ -233,7 +281,8 @@
'("/gnu/store")))) '("/gnu/store"))))
(inferior-eval '(use-modules (srfi srfi-1) (inferior-eval '(use-modules (srfi srfi-1)
(srfi srfi-34) (srfi srfi-34)
(guix grafts)) (guix grafts)
(guix derivations))
inf) inf)
(inferior-eval '(%graft? #f) inf) (inferior-eval '(%graft? #f) inf)
@ -298,4 +347,3 @@
id id
"'")))) "'"))))
(_ #f)))) (_ #f))))