cbaines pushed a commit to branch master
in repository data-service.
commit d3c87fb1dc2c3f72786904845edcedd921bbb24c
Author: Christopher Baines <[email protected]>
AuthorDate: Sun Dec 22 11:05:38 2024 +0000
Attempt to reduce memory churn when processing package metadata
---
guix-data-service/model/package-metadata.scm | 137 ++++++++++++++-------------
tests/model-package-metadata.scm | 6 +-
tests/model-package.scm | 6 +-
3 files changed, 83 insertions(+), 66 deletions(-)
diff --git a/guix-data-service/model/package-metadata.scm
b/guix-data-service/model/package-metadata.scm
index e450620..f1ffdbf 100644
--- a/guix-data-service/model/package-metadata.scm
+++ b/guix-data-service/model/package-metadata.scm
@@ -18,6 +18,7 @@
(define-module (guix-data-service model package-metadata)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-43)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (squee)
@@ -275,8 +276,13 @@ WHERE packages.id IN (
(define (inferior-packages->package-metadata-ids conn
package-metadata
license-set-ids)
- (define package-metadata-list
- (vector->list package-metadata))
+ (define (vector-zip . vecs)
+ (let ((result (make-vector (vector-length (first vecs)))))
+ (apply vector-map!
+ (lambda (i . vals)
+ (cdr vals))
+ (cons result vecs))
+ result))
(insert-missing-data-and-return-all-ids
conn
@@ -287,68 +293,71 @@ WHERE packages.id IN (
package_description_set_id
package_synopsis_set_id)
- (list->vector
- (zip
- (map (match-lambda
- ((home-page rest ...)
- (if (string? home-page)
- home-page
- NULL)))
- package-metadata-list)
- (with-time-logging "preparing location ids"
- (map (match-lambda
- ((_ location rest ...)
- (if location
- (location->location-id
- conn
- location)
- NULL)))
- package-metadata-list))
- (vector->list license-set-ids)
- (with-time-logging "preparing package description set ids"
- (map (lambda (package-description-ids)
- (insert-and-return-id
- conn
- "package_description_sets"
- '(description_ids)
- (list (sort package-description-ids <))))
- (with-time-logging "preparing package description ids"
- (map (match-lambda
- ((_ _ package-description-data _)
- (insert-missing-data-and-return-all-ids
- conn
- "package_descriptions"
- '(locale description)
- (list->vector
- (map (match-lambda
- ((locale . description)
- (list locale
- ;; \u0000 has appeared in package
- ;; descriptions (#71968), so strip it
- ;; out here to avoid PostgreSQL throwing
- ;; an error
- (string-delete-null description))))
- package-description-data)))))
- package-metadata-list))))
- (with-time-logging "preparing package synopsis set ids"
- (map (lambda (package-synopsis-ids)
- (insert-and-return-id
- conn
- "package_synopsis_sets"
- '(synopsis_ids)
- (list (sort package-synopsis-ids <))))
- (map (match-lambda
- ((_ _ _ package-synopsis-data)
- (insert-missing-data-and-return-all-ids
- conn
- "package_synopsis"
- '(locale synopsis)
- (list->vector
- (map (match-lambda
- ((locale . synopsis)
- (list locale synopsis)))
- package-synopsis-data)))))
- package-metadata-list)))))))
+ (vector-zip
+ (vector-map (match-lambda*
+ ((_ (home-page rest ...))
+ (if (string? home-page)
+ home-page
+ NULL)))
+ package-metadata)
+ (with-time-logging "preparing location ids"
+ (vector-map (match-lambda*
+ ((_ (_ location rest ...))
+ (if location
+ (location->location-id
+ conn
+ location)
+ NULL)))
+ package-metadata))
+ license-set-ids
+ (with-time-logging "preparing package description set ids"
+ (vector-map (match-lambda*
+ ((_ (_ _ package-description-data _))
+ (let ((package-description-ids
+ (insert-missing-data-and-return-all-ids
+ conn
+ "package_descriptions"
+ '(locale description)
+ (let ((vec (list->vector
package-description-data)))
+ (vector-map!
+ (match-lambda*
+ ((_ (locale . description))
+ (list locale
+ ;; \u0000 has appeared in package
+ ;; descriptions (#71968), so strip it
+ ;; out here to avoid PostgreSQL
throwing
+ ;; an error
+ (string-delete-null description))))
+ vec)
+ vec))))
+ (insert-and-return-id
+ conn
+ "package_description_sets"
+ '(description_ids)
+ (list (sort! package-description-ids <))))))
+ package-metadata))
+ (with-time-logging "preparing package synopsis set ids"
+ (vector-map (match-lambda*
+ ((_ (_ _ _ package-synopsis-data))
+ (let ((package-synopsis-ids
+ (insert-missing-data-and-return-all-ids
+ conn
+ "package_synopsis"
+ '(locale synopsis)
+ (let ((vec
+ (list->vector package-synopsis-data)))
+ (vector-map!
+ (match-lambda*
+ ((_ (locale . synopsis))
+ (list locale synopsis)))
+ vec)
+ vec))))
+ (insert-and-return-id
+ conn
+ "package_synopsis_sets"
+ '(synopsis_ids)
+ (list (sort! package-synopsis-ids <))))))
+ package-metadata)))))
(define (package-description-and-synopsis-locale-options-guix-revision conn
revision-id)
diff --git a/tests/model-package-metadata.scm b/tests/model-package-metadata.scm
index c262f57..5e9c897 100644
--- a/tests/model-package-metadata.scm
+++ b/tests/model-package-metadata.scm
@@ -48,6 +48,9 @@
(inferior-packages->license-id-lists
conn
'#((("License 1"
+ "https://gnu.org/licenses/test-1.html";
+ "https://example.com/why-license-1";))
+ (("License 1"
"https://gnu.org/licenses/test-1.html";
"https://example.com/why-license-1";))))))
@@ -74,7 +77,8 @@
conn
mock-package-metadata
(test-license-set-ids conn))
- (#(x) (number? x))))
+ (#(x y) (and (number? x)
+ (number? y)))))
#:always-rollback? #t))
(with-postgresql-transaction
diff --git a/tests/model-package.scm b/tests/model-package.scm
index 70882bd..f58b887 100644
--- a/tests/model-package.scm
+++ b/tests/model-package.scm
@@ -37,6 +37,9 @@
(inferior-packages->license-id-lists
conn
'#((("License 1"
+ "https://gnu.org/licenses/test-1.html";
+ "https://example.com/why-license-1";))
+ (("License 1"
"https://gnu.org/licenses/test-1.html";
"https://example.com/why-license-1";))))))
@@ -87,7 +90,8 @@
(map mock-inferior-package-version
mock-inferior-packages)
(vector->list package-metadata-ids)
package-replacement-package-ids)))
- (#(x) (number? x))))))
+ (#(x y) (and (number? x)
+ (number? y)))))))
#:always-rollback? #t)
(with-postgresql-transaction
