From b7b0ac85443c719a616edee6963578e58396f339 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Tue, 26 Oct 2021 10:46:12 +0200
Subject: 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(-)

(limited to 'guix/packages.scm')

diff --git a/guix/packages.scm b/guix/packages.scm
index b99689b9a4..780c6ddb65 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
-- 
cgit v1.2.3