me
/
guix
Archived
1
0
Fork 0
Code

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.
master
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 @@ in INPUTS and their transitive propagated inputs."
(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