02/02: packages: 'generate-package-cache' is deterministic.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit a127e52f601ee73f675d5d28eac2388bb1ad11b0
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Jul 30 16:37:19 2020 +0200

    packages: 'generate-package-cache' is deterministic.
    
    Fixes <https://bugs.gnu.org/42009>.
    Reported by Marinus <marinus.savoritias@disroot.org>.
    
    * gnu/packages.scm (generate-package-cache)[entry-key, entry<?]
    [variables]: New variables.
    [expand-cache]: Change to take two arguments.
    [exp]: Fold over VARIABLES.
---
 gnu/packages.scm | 82 +++++++++++++++++++++++++++++++++++---------------------
 1 file changed, 51 insertions(+), 31 deletions(-)

diff --git a/gnu/packages.scm b/gnu/packages.scm
index 4e42826..ccfc83d 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -381,39 +381,59 @@ reducing the memory footprint."
   (define cache-file
     (string-append directory %package-cache-file))
 
-  (define (expand-cache module symbol variable result+seen)
-    (match (false-if-exception (variable-ref variable))
-      ((? package? package)
-       (match result+seen
-         ((result . seen)
-          (if (or (vhash-assq package seen)
-                  (hidden-package? package))
-              (cons result seen)
-              (cons (cons `#(,(package-name package)
-                             ,(package-version package)
-                             ,(module-name module)
-                             ,symbol
-                             ,(package-outputs package)
-                             ,(->bool (supported-package? package))
-                             ,(->bool (package-superseded package))
-                             ,@(let ((loc (package-location package)))
-                                 (if loc
-                                     `(,(location-file loc)
-                                       ,(location-line loc)
-                                       ,(location-column loc))
-                                     '(#f #f #f))))
-                          result)
-                    (vhash-consq package #t seen))))))
-      (_
-       result+seen)))
-
-  (define exp
-    (first
-     (fold-module-public-variables* expand-cache
-                                    (cons '() vlist-null)
+  (define expand-cache
+    (match-lambda*
+      (((module symbol variable) (result . seen))
+       (let ((package (variable-ref variable)))
+         (if (or (vhash-assq package seen)
+                 (hidden-package? package))
+             (cons result seen)
+             (cons (cons `#(,(package-name package)
+                            ,(package-version package)
+                            ,(module-name module)
+                            ,symbol
+                            ,(package-outputs package)
+                            ,(->bool (supported-package? package))
+                            ,(->bool (package-superseded package))
+                            ,@(let ((loc (package-location package)))
+                                (if loc
+                                    `(,(location-file loc)
+                                      ,(location-line loc)
+                                      ,(location-column loc))
+                                    '(#f #f #f))))
+                         result)
+                   (vhash-consq package #t seen)))))))
+
+  (define entry-key
+    (match-lambda
+      ((module symbol variable)
+       (let ((value (variable-ref variable)))
+         (string-append (package-name value) (package-version value)
+                        (object->string module)
+                        (symbol->string symbol))))))
+
+  (define (entry<? a b)
+    (string<? (entry-key a) (entry-key b)))
+
+  (define variables
+    ;; First sort variables so that 'expand-cache' later dismisses
+    ;; already-seen package objects in a deterministic fashion.
+    (sort
+     (fold-module-public-variables* (lambda (module symbol variable lst)
+                                      (let ((value (false-if-exception
+                                                    (variable-ref variable))))
+                                        (if (package? value)
+                                            (cons (list module symbol variable)
+                                                  lst)
+                                            lst)))
+                                    '()
                                     (all-modules (%package-module-path)
                                                  #:warn
-                                                 warn-about-load-error))))
+                                                 warn-about-load-error))
+     entry<?))
+
+  (define exp
+    (first (fold expand-cache (cons '() vlist-null) variables)))
 
   (mkdir-p (dirname cache-file))
   (call-with-output-file cache-file