01/05: packages: Optimize 'package-transitive-supported-systems'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit b7b0ac85443c719a616edee6963578e58396f339
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Tue Oct 26 10:46:12 2021 +0200

    packages: Optimize 'package-transitive-supported-systems'.
    
    With this change, the wall-clock time of:
    
      ./pre-inst-env guile -c '(use-modules (gnu) (guix)(ice-9 time)) (time (pk 
(fold-packages (lambda (p r)(supported-package? p)(+ 1 r)) 0)))'
    
    goes from 3.2s to 2.0s, a 37% improvement.
    
    * guix/packages.scm (package-transitive-supported-systems): Change
    'supported-systems' to 'supported-systems-procedure', returning an
    'mlambdaq' instead of the original 'mlambda'.  Add 'procs'.  Adjust body
    accordingly.
---
 guix/packages.scm | 39 ++++++++++++++++++++++++++-------------
 1 file changed, 26 insertions(+), 13 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index b99689b..780c6dd 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1018,23 +1018,36 @@ in INPUTS and their transitive propagated inputs."
 
 (define package-transitive-supported-systems
   (let ()
-    (define supported-systems
-      (mlambda (package system)
-        (parameterize ((%current-system system))
-          (fold (lambda (input systems)
-                  (match input
-                    ((label (? package? package) . _)
-                     (lset-intersection string=? systems
-                                        (supported-systems package system)))
-                    (_
-                     systems)))
-                (package-supported-systems package)
-                (bag-direct-inputs (package->bag package))))))
+    (define (supported-systems-procedure system)
+      (define supported-systems
+        (mlambdaq (package)
+          (parameterize ((%current-system system))
+            (fold (lambda (input systems)
+                    (match input
+                      ((label (? package? package) . _)
+                       (lset-intersection string=? systems
+                                          (supported-systems package)))
+                      (_
+                       systems)))
+                  (package-supported-systems package)
+                  (bag-direct-inputs (package->bag package))))))
+
+      supported-systems)
+
+    (define procs
+      ;; Map system strings to one-argument procedures.  This allows these
+      ;; procedures to have fast 'eq?' memoization on their argument.
+      (make-hash-table))
 
     (lambda* (package #:optional (system (%current-system)))
       "Return the intersection of the systems supported by PACKAGE and those
 supported by its dependencies."
-      (supported-systems package system))))
+      (match (hash-ref procs system)
+        (#f
+         (hash-set! procs system (supported-systems-procedure system))
+         (package-transitive-supported-systems package system))
+        (proc
+         (proc package))))))
 
 (define* (supported-package? package #:optional (system (%current-system)))
   "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its