Allow specifying a limit to inferior memory usage
To help manage the inferiors that use gigabytes of memory while computing derivations.
This commit is contained in:
parent
f9770b8d59
commit
7c0779519b
5 changed files with 138 additions and 131 deletions
|
|
@ -146,6 +146,7 @@ WHERE load_new_guix_revision_jobs.id = $1"
|
|||
per-job-parallelism
|
||||
ignore-systems
|
||||
ignore-targets
|
||||
inferior-memory-limit
|
||||
(free-space-requirement
|
||||
;; 2G
|
||||
(* 2 (expt 2 30)))
|
||||
|
|
@ -178,6 +179,10 @@ WHERE load_new_guix_revision_jobs.id = $1"
|
|||
,@(if per-job-parallelism
|
||||
(list (simple-format #f "--parallelism=~A" per-job-parallelism))
|
||||
'())
|
||||
,@(if inferior-memory-limit
|
||||
(list (simple-format #f "--inferior-memory-limit=~A"
|
||||
inferior-memory-limit))
|
||||
'())
|
||||
,@(if (null? ignore-systems)
|
||||
'()
|
||||
(list (simple-format #f "--ignore-systems=~A"
|
||||
|
|
|
|||
|
|
@ -1435,13 +1435,89 @@ WHERE builder != 'builtin:download'
|
|||
#:parallelism 1
|
||||
#:drain? #t))
|
||||
|
||||
(define* (call-with-inferior inf-and-store-pool proc
|
||||
#:key memory-limit)
|
||||
(define (check-wal-size)
|
||||
(define (get-wal-bytes)
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(stat:size (stat "/var/guix/db/db.sqlite-wal")))
|
||||
(lambda _ 0)))
|
||||
|
||||
(define threshold
|
||||
(max
|
||||
(* 4096 (expt 2 20))
|
||||
(* 0.8
|
||||
(- (free-disk-space "/var/guix/db/db.sqlite")
|
||||
(get-wal-bytes)))))
|
||||
|
||||
(if (< (get-wal-bytes) threshold)
|
||||
#t
|
||||
(let loop ((wal-bytes (get-wal-bytes)))
|
||||
(if (> wal-bytes threshold)
|
||||
(let ((stats (resource-pool-stats inf-and-store-pool)))
|
||||
(simple-format
|
||||
#t "debug: guix-daemon WAL is large (~A), ~A inferiors, waiting\n"
|
||||
wal-bytes
|
||||
(assq-ref stats 'resources))
|
||||
|
||||
(sleep 30)
|
||||
(loop (get-wal-bytes)))
|
||||
(begin
|
||||
(simple-format
|
||||
#t "debug: guix-daemon WAL now ~A bytes, continuing\n"
|
||||
wal-bytes)
|
||||
#t)))))
|
||||
|
||||
(define (check-memory-usage inferior)
|
||||
(let ((heap-size
|
||||
(inferior-eval
|
||||
'(let ((stats (gc-stats)))
|
||||
(assoc-ref stats 'heap-size))
|
||||
inferior)))
|
||||
(when (> heap-size memory-limit)
|
||||
(simple-format
|
||||
#t
|
||||
"debug: inferior using more than ~A bytes of memory (~A), destroying\n"
|
||||
memory-limit heap-size)
|
||||
(raise-exception
|
||||
(make-resource-pool-destroy-resource-exception)))))
|
||||
|
||||
(let loop ()
|
||||
(check-wal-size)
|
||||
(match
|
||||
(with-exception-handler
|
||||
(lambda (exn)
|
||||
(if (or (resource-pool-timeout-error? exn)
|
||||
(resource-pool-destroy-resource-exception? exn))
|
||||
'retry
|
||||
(raise-exception exn)))
|
||||
(lambda ()
|
||||
(call-with-resource-from-pool inf-and-store-pool
|
||||
(match-lambda
|
||||
((inferior . inferior-store)
|
||||
(when memory-limit
|
||||
(check-memory-usage inferior))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(proc inferior inferior-store))
|
||||
(lambda vals
|
||||
(simple-format #t "debug: returning inferior to pool\n")
|
||||
(cons 'result vals)))))
|
||||
#:timeout 20))
|
||||
#:unwind? #t)
|
||||
('retry (loop))
|
||||
(('result . vals)
|
||||
(apply values vals)))))
|
||||
|
||||
(define* (compute-and-fix-broken-derivations-in-revision
|
||||
git-repository-id commit
|
||||
#:key
|
||||
(ignore-systems '())
|
||||
(ignore-targets '())
|
||||
(extra-inferior-environment-variables '())
|
||||
(parallelism 4))
|
||||
(parallelism 4)
|
||||
inferior-memory-limit)
|
||||
(let ((broken-derivations
|
||||
(find-broken-derivations-in-revision commit)))
|
||||
(run-fibers
|
||||
|
|
@ -1525,69 +1601,14 @@ WHERE builder != 'builtin:download'
|
|||
(close-connection store)
|
||||
(close-inferior inferior)))))
|
||||
|
||||
(define (call-with-inferior proc)
|
||||
(define (check-wal-size)
|
||||
(define (get-wal-bytes)
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(stat:size (stat "/var/guix/db/db.sqlite-wal")))
|
||||
(lambda _ 0)))
|
||||
|
||||
(define threshold
|
||||
(max
|
||||
(* 4096 (expt 2 20))
|
||||
(* 0.8
|
||||
(- (free-disk-space "/var/guix/db/db.sqlite")
|
||||
(get-wal-bytes)))))
|
||||
|
||||
(if (< (get-wal-bytes) threshold)
|
||||
#t
|
||||
(let loop ((wal-bytes (get-wal-bytes)))
|
||||
(if (> wal-bytes threshold)
|
||||
(let ((stats (resource-pool-stats inf-and-store-pool)))
|
||||
(simple-format
|
||||
#t "debug: guix-daemon WAL is large (~A), ~A inferiors, waiting\n"
|
||||
wal-bytes
|
||||
(assq-ref stats 'resources))
|
||||
|
||||
(sleep 30)
|
||||
(loop (get-wal-bytes)))
|
||||
(begin
|
||||
(simple-format
|
||||
#t "debug: guix-daemon WAL now ~A bytes, continuing\n"
|
||||
wal-bytes)
|
||||
#t)))))
|
||||
|
||||
(let loop ()
|
||||
(check-wal-size)
|
||||
(match
|
||||
(with-exception-handler
|
||||
(lambda (exn)
|
||||
(if (resource-pool-timeout-error? exn)
|
||||
'retry
|
||||
(raise-exception exn)))
|
||||
(lambda ()
|
||||
(call-with-resource-from-pool inf-and-store-pool
|
||||
(match-lambda
|
||||
((inferior . inferior-store)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(proc inferior inferior-store))
|
||||
(lambda vals
|
||||
(simple-format #t "debug: returning inferior to pool\n")
|
||||
(cons 'result vals)))))
|
||||
#:timeout 20))
|
||||
#:unwind? #t)
|
||||
('retry (loop))
|
||||
(('result . vals)
|
||||
(apply values vals)))))
|
||||
|
||||
(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))))
|
||||
(inferior-eval '(vector-length gds-inferior-packages) inferior))
|
||||
#:memory-limit inferior-memory-limit))
|
||||
|
||||
(define chunk-size 1000)
|
||||
|
||||
|
|
@ -1610,6 +1631,7 @@ WHERE builder != 'builtin:download'
|
|||
chunk-size))
|
||||
(chunk
|
||||
(call-with-inferior
|
||||
inf-and-store-pool
|
||||
(lambda (inferior inferior-store)
|
||||
(ensure-gds-inferior-packages-defined! inferior)
|
||||
|
||||
|
|
@ -1625,7 +1647,8 @@ WHERE builder != 'builtin:download'
|
|||
(when last-chunk?
|
||||
(inferior-cleanup inferior))
|
||||
|
||||
result)))))
|
||||
result))
|
||||
#:memory-limit inferior-memory-limit)))
|
||||
(unless last-chunk?
|
||||
(loop (+ start-index chunk-size))))))))
|
||||
|
||||
|
|
@ -1637,8 +1660,10 @@ WHERE builder != 'builtin:download'
|
|||
(list
|
||||
(let ((all-system-target-pairs
|
||||
(call-with-inferior
|
||||
inf-and-store-pool
|
||||
(lambda (inferior inferior-store)
|
||||
(inferior-fetch-system-target-pairs inferior)))))
|
||||
(inferior-fetch-system-target-pairs inferior))
|
||||
#:memory-limit inferior-memory-limit)))
|
||||
(filter
|
||||
(match-lambda
|
||||
((system . target)
|
||||
|
|
@ -2345,7 +2370,8 @@ WHERE builder != 'builtin:download'
|
|||
#:key skip-system-tests?
|
||||
extra-inferior-environment-variables
|
||||
parallelism
|
||||
ignore-systems ignore-targets)
|
||||
ignore-systems ignore-targets
|
||||
inferior-memory-limit)
|
||||
|
||||
(define guix-locpath
|
||||
;; Augment the GUIX_LOCPATH to include glibc-locales from
|
||||
|
|
@ -2404,63 +2430,6 @@ WHERE builder != 'builtin:download'
|
|||
(close-connection store)
|
||||
(close-inferior inferior)))))
|
||||
|
||||
(define (call-with-inferior proc)
|
||||
(define (check-wal-size)
|
||||
(define (get-wal-bytes)
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(stat:size (stat "/var/guix/db/db.sqlite-wal")))
|
||||
(lambda _ 0)))
|
||||
|
||||
(define threshold
|
||||
(max
|
||||
(* 4096 (expt 2 20))
|
||||
(* 0.8
|
||||
(- (free-disk-space "/var/guix/db/db.sqlite")
|
||||
(get-wal-bytes)))))
|
||||
|
||||
(if (< (get-wal-bytes) threshold)
|
||||
#t
|
||||
(let loop ((wal-bytes (get-wal-bytes)))
|
||||
(if (> wal-bytes threshold)
|
||||
(let ((stats (resource-pool-stats inf-and-store-pool)))
|
||||
(simple-format
|
||||
#t "debug: guix-daemon WAL is large (~A), ~A inferiors, waiting\n"
|
||||
wal-bytes
|
||||
(assq-ref stats 'resources))
|
||||
|
||||
(sleep 30)
|
||||
(loop (get-wal-bytes)))
|
||||
(begin
|
||||
(simple-format
|
||||
#t "debug: guix-daemon WAL now ~A bytes, continuing\n"
|
||||
wal-bytes)
|
||||
#t)))))
|
||||
|
||||
(let loop ()
|
||||
(check-wal-size)
|
||||
(match
|
||||
(with-exception-handler
|
||||
(lambda (exn)
|
||||
(if (resource-pool-timeout-error? exn)
|
||||
'retry
|
||||
(raise-exception exn)))
|
||||
(lambda ()
|
||||
(call-with-resource-from-pool inf-and-store-pool
|
||||
(match-lambda
|
||||
((inferior . inferior-store)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(proc inferior inferior-store))
|
||||
(lambda vals
|
||||
(simple-format #t "debug: returning inferior to pool\n")
|
||||
(cons 'result vals)))))
|
||||
#:timeout 20))
|
||||
#:unwind? #t)
|
||||
('retry (loop))
|
||||
(('result . vals)
|
||||
(apply values vals)))))
|
||||
|
||||
(define postgresql-connection-pool
|
||||
(make-resource-pool
|
||||
(lambda ()
|
||||
|
|
@ -2484,6 +2453,7 @@ WHERE builder != 'builtin:download'
|
|||
(lambda ()
|
||||
(let ((packages-data
|
||||
(call-with-inferior
|
||||
inf-and-store-pool
|
||||
(lambda (inferior inferior-store)
|
||||
(with-time-logging "getting all inferior package data"
|
||||
(let ((packages
|
||||
|
|
@ -2494,16 +2464,19 @@ WHERE builder != 'builtin:download'
|
|||
(all-inferior-packages-data
|
||||
inferior
|
||||
packages
|
||||
pkg-to-replacement-hash-table)))))))
|
||||
pkg-to-replacement-hash-table))))
|
||||
#:memory-limit inferior-memory-limit)))
|
||||
(with-resource-from-pool postgresql-connection-pool conn
|
||||
(insert-packages conn packages-data))))))
|
||||
|
||||
(define (extract-and-store-lint-checkers-and-warnings)
|
||||
(define inferior-lint-checkers-data
|
||||
(call-with-inferior
|
||||
inf-and-store-pool
|
||||
(lambda (inferior inferior-store)
|
||||
(list->vector
|
||||
(inferior-lint-checkers inferior)))))
|
||||
(inferior-lint-checkers inferior)))
|
||||
#:memory-limit inferior-memory-limit))
|
||||
|
||||
(when inferior-lint-checkers-data
|
||||
(fibers-let ((lint-checker-ids
|
||||
|
|
@ -2530,10 +2503,12 @@ WHERE builder != 'builtin:download'
|
|||
(not (eq? checker-name 'derivation)))
|
||||
(begin
|
||||
(call-with-inferior
|
||||
inf-and-store-pool
|
||||
(lambda (inferior inferior-store)
|
||||
(inferior-lint-warnings inferior
|
||||
inferior-store
|
||||
checker-name)))))))
|
||||
checker-name))
|
||||
#:memory-limit inferior-memory-limit)))))
|
||||
inferior-lint-checkers-data)))
|
||||
|
||||
(let ((package-ids (fibers-force package-ids-promise)))
|
||||
|
|
@ -2562,10 +2537,12 @@ WHERE builder != 'builtin:download'
|
|||
(define (extract-and-store-package-derivations)
|
||||
(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))))
|
||||
(inferior-eval '(vector-length gds-inferior-packages) inferior))
|
||||
#:memory-limit inferior-memory-limit))
|
||||
|
||||
(define chunk-size 1000)
|
||||
|
||||
|
|
@ -2589,6 +2566,7 @@ WHERE builder != 'builtin:download'
|
|||
chunk-size))
|
||||
(chunk
|
||||
(call-with-inferior
|
||||
inf-and-store-pool
|
||||
(lambda (inferior inferior-store)
|
||||
(ensure-gds-inferior-packages-defined! inferior)
|
||||
|
||||
|
|
@ -2604,7 +2582,8 @@ WHERE builder != 'builtin:download'
|
|||
(when last-chunk?
|
||||
(inferior-cleanup inferior))
|
||||
|
||||
result)))))
|
||||
result))
|
||||
#:memory-limit inferior-memory-limit)))
|
||||
(vector-copy! derivations-vector
|
||||
start-index
|
||||
chunk)
|
||||
|
|
@ -2663,8 +2642,10 @@ WHERE builder != 'builtin:download'
|
|||
(list
|
||||
(let ((all-system-target-pairs
|
||||
(call-with-inferior
|
||||
inf-and-store-pool
|
||||
(lambda (inferior inferior-store)
|
||||
(inferior-fetch-system-target-pairs inferior)))))
|
||||
(inferior-fetch-system-target-pairs inferior))
|
||||
#:memory-limit inferior-memory-limit)))
|
||||
(filter
|
||||
(match-lambda
|
||||
((system . target)
|
||||
|
|
@ -2699,6 +2680,7 @@ WHERE builder != 'builtin:download'
|
|||
(with-time-logging "extract-and-store-system-tests"
|
||||
(let ((data-with-derivation-file-names
|
||||
(call-with-inferior
|
||||
inf-and-store-pool
|
||||
(lambda (inferior inferior-store)
|
||||
(with-time-logging "getting inferior system tests"
|
||||
(all-inferior-system-tests
|
||||
|
|
@ -2706,7 +2688,8 @@ WHERE builder != 'builtin:download'
|
|||
inferior-store
|
||||
guix-source
|
||||
commit
|
||||
#:ignore-systems ignore-systems))))))
|
||||
#:ignore-systems ignore-systems)))
|
||||
#:memory-limit inferior-memory-limit)))
|
||||
(when data-with-derivation-file-names
|
||||
(let ((data-with-derivation-ids
|
||||
(map (match-lambda
|
||||
|
|
@ -2821,7 +2804,8 @@ WHERE builder != 'builtin:download'
|
|||
(define* (load-new-guix-revision conn git-repository-id commit
|
||||
#:key skip-system-tests? parallelism
|
||||
extra-inferior-environment-variables
|
||||
ignore-systems ignore-targets)
|
||||
ignore-systems ignore-targets
|
||||
inferior-memory-limit)
|
||||
(define call-with-utility-thread
|
||||
(let* ((thread-pool
|
||||
(make-fixed-size-thread-pool parallelism))
|
||||
|
|
@ -2926,7 +2910,9 @@ WHERE builder != 'builtin:download'
|
|||
extra-inferior-environment-variables
|
||||
#:ignore-systems ignore-systems
|
||||
#:ignore-targets ignore-targets
|
||||
#:parallelism parallelism)
|
||||
#:parallelism parallelism
|
||||
#:inferior-memory-limit
|
||||
inferior-memory-limit)
|
||||
(let ((guix-revision-id
|
||||
(fibers-force guix-revision-id-promise)))
|
||||
(destroy-parallelism-limiter
|
||||
|
|
@ -3353,6 +3339,7 @@ SKIP LOCKED")
|
|||
extra-inferior-environment-variables
|
||||
ignore-systems
|
||||
ignore-targets
|
||||
inferior-memory-limit
|
||||
parallelism)
|
||||
(define finished-channel
|
||||
(make-channel))
|
||||
|
|
@ -3443,7 +3430,8 @@ SKIP LOCKED")
|
|||
extra-inferior-environment-variables
|
||||
#:ignore-systems ignore-systems
|
||||
#:ignore-targets ignore-targets
|
||||
#:parallelism parallelism))
|
||||
#:parallelism parallelism
|
||||
#:inferior-memory-limit inferior-memory-limit))
|
||||
|
||||
(record-job-succeeded conn id)
|
||||
(record-job-event conn id "success")
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue