diff --git a/guix-data-service/jobs.scm b/guix-data-service/jobs.scm index 3ea1ebf..85c4c2e 100644 --- a/guix-data-service/jobs.scm +++ b/guix-data-service/jobs.scm @@ -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" diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm index c0433e4..a9dedc4 100644 --- a/guix-data-service/jobs/load-new-guix-revision.scm +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -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") diff --git a/guix-dev.scm b/guix-dev.scm index 13d1e23..7de5b87 100644 --- a/guix-dev.scm +++ b/guix-dev.scm @@ -42,7 +42,7 @@ (srfi srfi-1)) (define guile-knots - (let ((commit "ab5411da423043f2b8a0e27c7507f8d9c34686a2") + (let ((commit "6f6d57b189a7073718407df263bbe3c1245f2e51") (revision "1")) (package (name "guile-knots") @@ -54,7 +54,7 @@ (commit commit))) (sha256 (base32 - "0v39yd9cfcwc23cmb4h89kvp9m96xdg47nbj2k80a43fbalfd9aq")) + "0kd2bzqn4lli66bzj2ks4ai3xznpbg9ckjswjbnp3qcds3ahfkb5")) (file-name (string-append name "-" version "-checkout")))) (build-system gnu-build-system) (native-inputs diff --git a/scripts/guix-data-service-process-job.in b/scripts/guix-data-service-process-job.in index 029090d..85e5631 100644 --- a/scripts/guix-data-service-process-job.in +++ b/scripts/guix-data-service-process-job.in @@ -52,6 +52,12 @@ (string->number arg) (alist-delete 'parallelism 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 (lambda (opt name arg result) (alist-cons 'inferior-environment-variable @@ -111,6 +117,7 @@ opts) #:ignore-systems (assq-ref opts 'ignore-systems) #:ignore-targets (assq-ref opts 'ignore-targets) + #:inferior-memory-limit (assq-ref opts 'inferior-memory-limit) #:parallelism (assq-ref opts 'parallelism))) #:unwind? #t)) #:hz 0 diff --git a/scripts/guix-data-service-process-jobs.in b/scripts/guix-data-service-process-jobs.in index ede8581..bc77874 100644 --- a/scripts/guix-data-service-process-jobs.in +++ b/scripts/guix-data-service-process-jobs.in @@ -52,6 +52,11 @@ (alist-cons 'per-job-parallelism (string->number arg) 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 (lambda (opt name arg result) (alist-cons 'inferior-environment-variable @@ -135,6 +140,8 @@ 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-targets (assq-ref opts 'ignore-targets) #:free-space-requirement