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

Allow specifying a limit to inferior memory usage

Browse source 
To help manage the inferiors that use gigabytes of memory while computing
derivations.
This commit is contained in:
Christopher Baines 2025-06-26 20:47:43 +02:00
parent f9770b8d59
commit 7c0779519b
5 changed files with 138 additions and 131 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -146,6 +146,7 @@ WHERE load_new_guix_revision_jobs.id = $1"
per-job-parallelism per-job-parallelism
ignore-systems ignore-systems
ignore-targets ignore-targets
inferior-memory-limit
(free-space-requirement (free-space-requirement
;; 2G ;; 2G
(* 2 (expt 2 30))) (* 2 (expt 2 30)))
@ -178,6 +179,10 @@ WHERE load_new_guix_revision_jobs.id = $1"
,@(if per-job-parallelism ,@(if per-job-parallelism
(list (simple-format #f "--parallelism=~A" 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) ,@(if (null? ignore-systems)
'() '()
(list (simple-format #f "--ignore-systems=~A" (list (simple-format #f "--ignore-systems=~A"

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

@ -1435,13 +1435,89 @@ WHERE builder != 'builtin:download'
#:parallelism 1 #:parallelism 1
#:drain? #t)) #: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 (define* (compute-and-fix-broken-derivations-in-revision
git-repository-id commit git-repository-id commit
#:key #:key
(ignore-systems '()) (ignore-systems '())
(ignore-targets '()) (ignore-targets '())
(extra-inferior-environment-variables '()) (extra-inferior-environment-variables '())
(parallelism 4)) (parallelism 4)
inferior-memory-limit)
(let ((broken-derivations (let ((broken-derivations
(find-broken-derivations-in-revision commit))) (find-broken-derivations-in-revision commit)))
(run-fibers (run-fibers
@ -1525,69 +1601,14 @@ WHERE builder != 'builtin:download'
(close-connection store) (close-connection store)
(close-inferior inferior))))) (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 (define packages-count
(call-with-inferior (call-with-inferior
inf-and-store-pool
(lambda (inferior inferior-store) (lambda (inferior inferior-store)
(ensure-gds-inferior-packages-defined! inferior) (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) (define chunk-size 1000)
@ -1610,6 +1631,7 @@ WHERE builder != 'builtin:download'
chunk-size)) chunk-size))
(chunk (chunk
(call-with-inferior (call-with-inferior
inf-and-store-pool
(lambda (inferior inferior-store) (lambda (inferior inferior-store)
(ensure-gds-inferior-packages-defined! inferior) (ensure-gds-inferior-packages-defined! inferior)
@ -1625,7 +1647,8 @@ WHERE builder != 'builtin:download'
(when last-chunk? (when last-chunk?
(inferior-cleanup inferior)) (inferior-cleanup inferior))
result))))) result))
#:memory-limit inferior-memory-limit)))
(unless last-chunk? (unless last-chunk?
(loop (+ start-index chunk-size)))))))) (loop (+ start-index chunk-size))))))))
@ -1637,8 +1660,10 @@ WHERE builder != 'builtin:download'
(list (list
(let ((all-system-target-pairs (let ((all-system-target-pairs
(call-with-inferior (call-with-inferior
inf-and-store-pool
(lambda (inferior inferior-store) (lambda (inferior inferior-store)
(inferior-fetch-system-target-pairs inferior))))) (inferior-fetch-system-target-pairs inferior))
#:memory-limit inferior-memory-limit)))
(filter (filter
(match-lambda (match-lambda
((system . target) ((system . target)
@ -2345,7 +2370,8 @@ WHERE builder != 'builtin:download'
#:key skip-system-tests? #:key skip-system-tests?
extra-inferior-environment-variables extra-inferior-environment-variables
parallelism parallelism
ignore-systems ignore-targets) ignore-systems ignore-targets
inferior-memory-limit)
(define guix-locpath (define guix-locpath
;; Augment the GUIX_LOCPATH to include glibc-locales from ;; Augment the GUIX_LOCPATH to include glibc-locales from
@ -2404,63 +2430,6 @@ WHERE builder != 'builtin:download'
(close-connection store) (close-connection store)
(close-inferior inferior))))) (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 (define postgresql-connection-pool
(make-resource-pool (make-resource-pool
(lambda () (lambda ()
@ -2484,6 +2453,7 @@ WHERE builder != 'builtin:download'
(lambda () (lambda ()
(let ((packages-data (let ((packages-data
(call-with-inferior (call-with-inferior
inf-and-store-pool
(lambda (inferior inferior-store) (lambda (inferior inferior-store)
(with-time-logging "getting all inferior package data" (with-time-logging "getting all inferior package data"
(let ((packages (let ((packages
@ -2494,16 +2464,19 @@ WHERE builder != 'builtin:download'
(all-inferior-packages-data (all-inferior-packages-data
inferior inferior
packages packages
pkg-to-replacement-hash-table))))))) pkg-to-replacement-hash-table))))
#:memory-limit inferior-memory-limit)))
(with-resource-from-pool postgresql-connection-pool conn (with-resource-from-pool postgresql-connection-pool conn
(insert-packages conn packages-data)))))) (insert-packages conn packages-data))))))
(define (extract-and-store-lint-checkers-and-warnings) (define (extract-and-store-lint-checkers-and-warnings)
(define inferior-lint-checkers-data (define inferior-lint-checkers-data
(call-with-inferior (call-with-inferior
inf-and-store-pool
(lambda (inferior inferior-store) (lambda (inferior inferior-store)
(list->vector (list->vector
(inferior-lint-checkers inferior))))) (inferior-lint-checkers inferior)))
#:memory-limit inferior-memory-limit))
(when inferior-lint-checkers-data (when inferior-lint-checkers-data
(fibers-let ((lint-checker-ids (fibers-let ((lint-checker-ids
@ -2530,10 +2503,12 @@ WHERE builder != 'builtin:download'
(not (eq? checker-name 'derivation))) (not (eq? checker-name 'derivation)))
(begin (begin
(call-with-inferior (call-with-inferior
inf-and-store-pool
(lambda (inferior inferior-store) (lambda (inferior inferior-store)
(inferior-lint-warnings inferior (inferior-lint-warnings inferior
inferior-store inferior-store
checker-name))))))) checker-name))
#:memory-limit inferior-memory-limit)))))
inferior-lint-checkers-data))) inferior-lint-checkers-data)))
(let ((package-ids (fibers-force package-ids-promise))) (let ((package-ids (fibers-force package-ids-promise)))
@ -2562,10 +2537,12 @@ WHERE builder != 'builtin:download'
(define (extract-and-store-package-derivations) (define (extract-and-store-package-derivations)
(define packages-count (define packages-count
(call-with-inferior (call-with-inferior
inf-and-store-pool
(lambda (inferior inferior-store) (lambda (inferior inferior-store)
(ensure-gds-inferior-packages-defined! inferior) (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) (define chunk-size 1000)
@ -2589,6 +2566,7 @@ WHERE builder != 'builtin:download'
chunk-size)) chunk-size))
(chunk (chunk
(call-with-inferior (call-with-inferior
inf-and-store-pool
(lambda (inferior inferior-store) (lambda (inferior inferior-store)
(ensure-gds-inferior-packages-defined! inferior) (ensure-gds-inferior-packages-defined! inferior)
@ -2604,7 +2582,8 @@ WHERE builder != 'builtin:download'
(when last-chunk? (when last-chunk?
(inferior-cleanup inferior)) (inferior-cleanup inferior))
result))))) result))
#:memory-limit inferior-memory-limit)))
(vector-copy! derivations-vector (vector-copy! derivations-vector
start-index start-index
chunk) chunk)
@ -2663,8 +2642,10 @@ WHERE builder != 'builtin:download'
(list (list
(let ((all-system-target-pairs (let ((all-system-target-pairs
(call-with-inferior (call-with-inferior
inf-and-store-pool
(lambda (inferior inferior-store) (lambda (inferior inferior-store)
(inferior-fetch-system-target-pairs inferior))))) (inferior-fetch-system-target-pairs inferior))
#:memory-limit inferior-memory-limit)))
(filter (filter
(match-lambda (match-lambda
((system . target) ((system . target)
@ -2699,6 +2680,7 @@ WHERE builder != 'builtin:download'
(with-time-logging "extract-and-store-system-tests" (with-time-logging "extract-and-store-system-tests"
(let ((data-with-derivation-file-names (let ((data-with-derivation-file-names
(call-with-inferior (call-with-inferior
inf-and-store-pool
(lambda (inferior inferior-store) (lambda (inferior inferior-store)
(with-time-logging "getting inferior system tests" (with-time-logging "getting inferior system tests"
(all-inferior-system-tests (all-inferior-system-tests
@ -2706,7 +2688,8 @@ WHERE builder != 'builtin:download'
inferior-store inferior-store
guix-source guix-source
commit commit
#:ignore-systems ignore-systems)))))) #:ignore-systems ignore-systems)))
#:memory-limit inferior-memory-limit)))
(when data-with-derivation-file-names (when data-with-derivation-file-names
(let ((data-with-derivation-ids (let ((data-with-derivation-ids
(map (match-lambda (map (match-lambda
@ -2821,7 +2804,8 @@ WHERE builder != 'builtin:download'
(define* (load-new-guix-revision conn git-repository-id commit (define* (load-new-guix-revision conn git-repository-id commit
#:key skip-system-tests? parallelism #:key skip-system-tests? parallelism
extra-inferior-environment-variables extra-inferior-environment-variables
ignore-systems ignore-targets) ignore-systems ignore-targets
inferior-memory-limit)
(define call-with-utility-thread (define call-with-utility-thread
(let* ((thread-pool (let* ((thread-pool
(make-fixed-size-thread-pool parallelism)) (make-fixed-size-thread-pool parallelism))
@ -2926,7 +2910,9 @@ WHERE builder != 'builtin:download'
extra-inferior-environment-variables extra-inferior-environment-variables
#:ignore-systems ignore-systems #:ignore-systems ignore-systems
#:ignore-targets ignore-targets #:ignore-targets ignore-targets
#:parallelism parallelism) #:parallelism parallelism
#:inferior-memory-limit
inferior-memory-limit)
(let ((guix-revision-id (let ((guix-revision-id
(fibers-force guix-revision-id-promise))) (fibers-force guix-revision-id-promise)))
(destroy-parallelism-limiter (destroy-parallelism-limiter
@ -3353,6 +3339,7 @@ SKIP LOCKED")
extra-inferior-environment-variables extra-inferior-environment-variables
ignore-systems ignore-systems
ignore-targets ignore-targets
inferior-memory-limit
parallelism) parallelism)
(define finished-channel (define finished-channel
(make-channel)) (make-channel))
@ -3443,7 +3430,8 @@ SKIP LOCKED")
extra-inferior-environment-variables extra-inferior-environment-variables
#:ignore-systems ignore-systems #:ignore-systems ignore-systems
#:ignore-targets ignore-targets #:ignore-targets ignore-targets
#:parallelism parallelism)) #:parallelism parallelism
#:inferior-memory-limit inferior-memory-limit))
(record-job-succeeded conn id) (record-job-succeeded conn id)
(record-job-event conn id "success") (record-job-event conn id "success")

4
guix-dev.scm
View file

@ -42,7 +42,7 @@
(srfi srfi-1)) (srfi srfi-1))
(define guile-knots (define guile-knots
(let ((commit "ab5411da423043f2b8a0e27c7507f8d9c34686a2") (let ((commit "6f6d57b189a7073718407df263bbe3c1245f2e51")
(revision "1")) (revision "1"))
(package (package
(name "guile-knots") (name "guile-knots")
@ -54,7 +54,7 @@
(commit commit))) (commit commit)))
(sha256 (sha256
(base32 (base32
"0v39yd9cfcwc23cmb4h89kvp9m96xdg47nbj2k80a43fbalfd9aq")) "0kd2bzqn4lli66bzj2ks4ai3xznpbg9ckjswjbnp3qcds3ahfkb5"))
(file-name (string-append name "-" version "-checkout")))) (file-name (string-append name "-" version "-checkout"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(native-inputs (native-inputs

7
scripts/guix-data-service-process-job.in
View file

@ -52,6 +52,12 @@
(string->number arg) (string->number arg)
(alist-delete 'parallelism (alist-delete 'parallelism
result)))) result))))
(option '("inferior-memory-limit") #t #f
(lambda (opt name arg result)
(alist-cons 'inferior-memory-limit
(string->number arg)
(alist-delete 'inferior-memory-limit
result))))
(option '("inferior-set-environment-variable") #t #f (option '("inferior-set-environment-variable") #t #f
(lambda (opt name arg result) (lambda (opt name arg result)
(alist-cons 'inferior-environment-variable (alist-cons 'inferior-environment-variable
@ -111,6 +117,7 @@
opts) opts)
#:ignore-systems (assq-ref opts 'ignore-systems) #:ignore-systems (assq-ref opts 'ignore-systems)
#:ignore-targets (assq-ref opts 'ignore-targets) #:ignore-targets (assq-ref opts 'ignore-targets)
#:inferior-memory-limit (assq-ref opts 'inferior-memory-limit)
#:parallelism (assq-ref opts 'parallelism))) #:parallelism (assq-ref opts 'parallelism)))
#:unwind? #t)) #:unwind? #t))
#:hz 0 #:hz 0

7
scripts/guix-data-service-process-jobs.in
View file

@ -52,6 +52,11 @@
(alist-cons 'per-job-parallelism (alist-cons 'per-job-parallelism
(string->number arg) (string->number arg)
result))) result)))
(option '("inferior-memory-limit") #t #f
(lambda (opt name arg result)
(alist-cons 'inferior-memory-limit
(string->number arg)
result)))
(option '("inferior-set-environment-variable") #t #f (option '("inferior-set-environment-variable") #t #f
(lambda (opt name arg result) (lambda (opt name arg result)
(alist-cons 'inferior-environment-variable (alist-cons 'inferior-environment-variable
@ -135,6 +140,8 @@
opts) opts)
#:per-job-parallelism #:per-job-parallelism
(assq-ref opts 'per-job-parallelism) (assq-ref opts 'per-job-parallelism)
#:inferior-memory-limit
(assq-ref opts 'inferior-memory-limit)
#:ignore-systems (assq-ref opts 'ignore-systems) #:ignore-systems (assq-ref opts 'ignore-systems)
#:ignore-targets (assq-ref opts 'ignore-targets) #:ignore-targets (assq-ref opts 'ignore-targets)
#:free-space-requirement #:free-space-requirement