mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-19 05:57:04 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

packages: Optimize 'package-transitive-supported-systems'.

Browse source 
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.
This commit is contained in:
Ludovic Courtès 2021-10-26 10:46:12 +02:00
parent b7a36599b4
commit b7b0ac8544
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 26 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

39
guix/packages.scm
View file

@ -1018,23 +1018,36 @@ (define label
(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