01/02: Use much smaller chunks when trying to run the derivation linter

[Christopher Baines]

cbaines pushed a commit to branch master
in repository data-service.

commit b3d59c650a45429f90953e8fd865a3ba76a891cf
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Mon Sep 5 14:22:38 2022 +0100

    Use much smaller chunks when trying to run the derivation linter
    
    Since larger chunks still ran in to inferior memory usage problems.
---
 guix-data-service/jobs/load-new-guix-revision.scm | 64 +++++++++++++++++------
 1 file changed, 48 insertions(+), 16 deletions(-)

diff --git a/guix-data-service/jobs/load-new-guix-revision.scm 
b/guix-data-service/jobs/load-new-guix-revision.scm
index 6f39bbc..e684ea0 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -457,6 +457,50 @@ WHERE job_id = $1")
       "vi_VN.UTF-8"
       "zh_CN.UTF-8"))
 
+  (define (cleanup-inferior inf)
+    (format (current-error-port)
+            "inferior heap before cleanup: ~a MiB used (~a MiB heap)~%"
+            (round
+             (/ (inferior-eval
+                 '(let ((stats (gc-stats)))
+                    (- (assoc-ref stats 'heap-size)
+                       (assoc-ref stats 'heap-free-size)))
+                 inf)
+                (expt 2. 20)))
+            (round
+             (/ (inferior-eval '(assoc-ref (gc-stats) 'heap-size) inf)
+                (expt 2. 20))))
+
+    ;; Clean the cached store connections, as there are caches associated with
+    ;; these that take up lots of memory
+    (inferior-eval
+     '(when (defined? '%store-table) (hash-clear! %store-table))
+     inf)
+
+    (catch
+      'match-error
+      (lambda ()
+        (inferior-eval '(invalidate-derivation-caches!) inf))
+      (lambda (key . args)
+        (simple-format
+         (current-error-port)
+         "warning: ignoring match-error from calling inferior 
invalidate-derivation-caches!\n")))
+
+    (inferior-eval '(gc) inf)
+
+    (format (current-error-port)
+            "inferior heap after cleanup: ~a MiB used (~a MiB heap)~%"
+            (round
+             (/ (inferior-eval
+                 '(let ((stats (gc-stats)))
+                    (- (assoc-ref stats 'heap-size)
+                       (assoc-ref stats 'heap-free-size)))
+                 inf)
+                (expt 2. 20)))
+            (round
+             (/ (inferior-eval '(assoc-ref (gc-stats) 'heap-size) inf)
+                (expt 2. 20)))))
+
   (define (lint-warnings-for-checker packages checker-name)
     `(lambda (store)
        (let* ((checker (find (lambda (checker)
@@ -591,7 +635,7 @@ WHERE job_id = $1")
               (with-time-logging (simple-format #f "getting ~A lint warnings"
                                                 name)
                 (let loop ((packages-chunks
-                            (chunk packages 15000))
+                            (chunk packages 4000))
                            (warnings '()))
 
                   (if (null? packages-chunks)
@@ -600,22 +644,10 @@ WHERE job_id = $1")
                              (inferior-eval-with-store
                               inf
                               store
-                              (lint-warnings-for-checker (car packages-chunks) 
name))))
-
-                        ;; Clean the cached store connections, as there are 
caches
-                        ;; associated with these that take up lots of memory
-                        (inferior-eval
-                         '(when (defined? '%store-table) (hash-clear! 
%store-table))
-                         inf)
-
-                        (inferior-eval '(gc) inf)
-
-                        (format (current-error-port)
-                                "inferior heap size: ~a MiB~%"
-                                (round
-                                 (/ (inferior-eval '(assoc-ref (gc-stats) 
'heap-size) inf)
-                                    (expt 2. 20))))
+                              (lint-warnings-for-checker (car packages-chunks)
+                                                         name))))
 
+                        (cleanup-inferior inf)
                         (loop (cdr packages-chunks)
                               (append! warnings
                                        new-warnings))))))))))