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.
This commit is contained in:
parent
ed4ba8eb95
commit
7df7fd3e52
1 changed files with 121 additions and 78 deletions
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue