mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-19 14:07:01 +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 (define package-transitive-supported-systems
(let () (let ()
(define supported-systems (define (supported-systems-procedure system)
(mlambda (package system) (define supported-systems
(parameterize ((%current-system system)) (mlambdaq (package)
(fold (lambda (input systems) (parameterize ((%current-system system))
(match input (fold (lambda (input systems)
((label (? package? package) . _) (match input
(lset-intersection string=? systems ((label (? package? package) . _)
(supported-systems package system))) (lset-intersection string=? systems
(_ (supported-systems package)))
systems))) (_
(package-supported-systems package) systems)))
(bag-direct-inputs (package->bag package)))))) (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))) (lambda* (package #:optional (system (%current-system)))
"Return the intersection of the systems supported by PACKAGE and those "Return the intersection of the systems supported by PACKAGE and those
supported by its dependencies." 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))) (define* (supported-package? package #:optional (system (%current-system)))
"Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its