nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

packages: Cache the result of 'package->bag'. 

This reduces the wall-clock time of

  guix environment gnutls --pure -E true

by ~25%.

* guix/packages.scm (%bag-cache): New variable.
(package->bag): Use 'cached' to cache things to %BAG-CACHE.
This commit is contained in:
Ludovic Courtès 2016-03-07 23:52:35 +01:00
parent 198d84b70b
commit 9775412ee0
1 changed files with 38 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
guix/packages.scm
View File

@ -798,41 +798,50 @@ information in exceptions."
(package package) (package package)
(input x))))))) (input x)))))))
(define %bag-cache
;; 'eq?' cache mapping packages to system+target+graft?-dependent bags.
;; It significantly speeds things up when doing repeated calls to
;; 'package->bag' as is the case when building a profile.
(make-weak-key-hash-table 200))
(define* (package->bag package #:optional (define* (package->bag package #:optional
(system (%current-system)) (system (%current-system))
(target (%current-target-system)) (target (%current-target-system))
#:key (graft? (%graft?))) #:key (graft? (%graft?)))
"Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET, "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET,
and return it." and return it."
;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked field (cached (=> %bag-cache)
;; values can refer to it. package (list system target graft?)
(parameterize ((%current-system system) ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked
(%current-target-system target)) ;; field values can refer to it.
(match (if graft? (parameterize ((%current-system system)
(or (package-replacement package) package) (%current-target-system target))
package) (match (if graft?
(($ <package> name version source build-system (or (package-replacement package) package)
args inputs propagated-inputs native-inputs self-native-input? package)
outputs) (($ <package> name version source build-system
(or (make-bag build-system (string-append name "-" version) args inputs propagated-inputs native-inputs
#:system system self-native-input? outputs)
#:target target (or (make-bag build-system (string-append name "-" version)
#:source source #:system system
#:inputs (append (inputs) #:target target
(propagated-inputs)) #:source source
#:outputs outputs #:inputs (append (inputs)
#:native-inputs `(,@(if (and target self-native-input?) (propagated-inputs))
`(("self" ,package)) #:outputs outputs
'()) #:native-inputs `(,@(if (and target
,@(native-inputs)) self-native-input?)
#:arguments (args)) `(("self" ,package))
(raise (if target '())
(condition ,@(native-inputs))
(&package-cross-build-system-error #:arguments (args))
(package package))) (raise (if target
(condition (condition
(&package-error (&package-cross-build-system-error
(package package)))))))))) (package package)))
(condition
(&package-error
(package package)))))))))))
(define (input-graft store system) (define (input-graft store system)
"Return a procedure that, given a package with a graft, returns a graft, and "Return a procedure that, given a package with a graft, returns a graft, and