me
/
guix
Archived
1
0
Fork 0
Code

packages: Core procedures are written in monadic style. 

This plays better with the functional object cache, which is no longer
lost across calls to procedures created by 'store-lift'.

* guix/packages.scm (input-graft, input-cross-graft): Remove 'store'
parameter.  Return a monadic procedure.
(bag-grafts): Remove 'store' parameter and turn into a monadic
procedure.
(graft-derivation*): New procedure.
(cached): Remove clause to match syntax without (=> CACHE).
(package-grafts): Define using 'store-lower'.
(package-grafts*): New procedure, from former 'package-grafts'.  Remove
'store' parameter and turn into a monadic procedure.
(package->derivation): Rewrite using 'mcached' and a monadic variant of
the former 'package-derivation' procedure.
(package->cross-derivation): Likewise.
(package-derivation, package-cross-derivation): Rewrite in terms of
'store-lower'.
(%graft-cache): Remove.
master
Ludovic Courtès 2017-06-28 21:57:16 +02:00
parent 37c32caf2c
commit 9e5812ac59
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 133 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

248
guix/packages.scm
View File

@ -1199,9 +1199,7 @@ Return the cached result when available."
(#f (cache! cache package key thunk)) (#f (cache! cache package key thunk))
(value value))) (value value)))
(#f (#f
(cache! cache package key thunk))))) (cache! cache package key thunk)))))))
((_ package system body ...)
(cached (=> %derivation-cache) package system body ...))))
(define* (expand-input package input #:key native?) (define* (expand-input package input #:key native?)
"Expand INPUT, an input tuple, to a name/<gexp-input> tuple. PACKAGE is "Expand INPUT, an input tuple, to a name/<gexp-input> tuple. PACKAGE is
@ -1277,45 +1275,51 @@ and return it."
(&package-error (&package-error
(package package)))))))))))) (package package))))))))))))
(define %graft-cache (define (input-graft system)
;; 'eq?' cache mapping package objects to a graft corresponding to their "Return a monadic procedure that, given a package with a graft, returns a
;; replacement package. graft, and #f otherwise."
(make-weak-key-hash-table 200)) (with-monad %store-monad
(match-lambda*
(((? package? package) output)
(let ((replacement (package-replacement package)))
(if replacement
;; XXX: We should use a separate cache instead of abusing the
;; object cache.
(mcached (mlet %store-monad ((orig (package->derivation package system
#:graft? #f))
(new (package->derivation replacement system
#:graft? #t)))
(return (graft
(origin orig)
(origin-output output)
(replacement new)
(replacement-output output))))
package 'graft output system)
(return #f))))
(_
(return #f)))))
(define (input-graft store system) (define (input-cross-graft target system)
"Return a procedure that, given a package with a replacement and an output name,
returns a graft, and #f otherwise."
(match-lambda*
(((? package? package) output)
(let ((replacement (package-replacement package)))
(and replacement
(cached (=> %graft-cache) package (cons output system)
(let ((orig (package-derivation store package system
#:graft? #f))
(new (package-derivation store replacement system
#:graft? #t)))
(graft
(origin orig)
(origin-output output)
(replacement new)
(replacement-output output)))))))))
(define (input-cross-graft store target system)
"Same as 'input-graft', but for cross-compilation inputs." "Same as 'input-graft', but for cross-compilation inputs."
(match-lambda* (with-monad %store-monad
(((? package? package) output) (match-lambda*
(let ((replacement (package-replacement package))) (((? package? package) output)
(and replacement (let ((replacement (package-replacement package)))
(let ((orig (package-cross-derivation store package target system (if replacement
#:graft? #f)) (mlet %store-monad ((orig (package->cross-derivation package
(new (package-cross-derivation store replacement target system
target system #:graft? #f))
#:graft? #t))) (new (package->cross-derivation replacement
(graft target system
(origin orig) #:graft? #t)))
(origin-output output) (return (graft
(replacement new) (origin orig)
(replacement-output output)))))))) (origin-output output)
(replacement new)
(replacement-output output))))
(return #f))))
(_
(return #f)))))
(define* (fold-bag-dependencies proc seed bag (define* (fold-bag-dependencies proc seed bag
#:key (native? #t)) #:key (native? #t))
@ -1350,7 +1354,7 @@ dependencies; otherwise, restrict to target dependencies."
((head . tail) ((head . tail)
(loop tail result visited))))) (loop tail result visited)))))
(define* (bag-grafts store bag) (define* (bag-grafts bag)
"Return the list of grafts potentially applicable to BAG. Potentially "Return the list of grafts potentially applicable to BAG. Potentially
applicable grafts are collected by looking at direct or indirect dependencies applicable grafts are collected by looking at direct or indirect dependencies
of BAG that have a 'replacement'. Whether a graft is actually applicable of BAG that have a 'replacement'. Whether a graft is actually applicable
@ -1359,46 +1363,55 @@ to (see 'graft-derivation'.)"
(define system (bag-system bag)) (define system (bag-system bag))
(define target (bag-target bag)) (define target (bag-target bag))
(define native-grafts (mlet %store-monad
(let ((->graft (input-graft store system))) ((native-grafts
(parameterize ((%current-system system) (let ((->graft (input-graft system)))
(%current-target-system #f))
(fold-bag-dependencies (lambda (package output grafts)
(match (->graft package output)
(#f grafts)
(graft (cons graft grafts))))
'()
bag))))
(define target-grafts
(if target
(let ((->graft (input-cross-graft store target system)))
(parameterize ((%current-system system) (parameterize ((%current-system system)
(%current-target-system target)) (%current-target-system #f))
(fold-bag-dependencies (lambda (package output grafts) (fold-bag-dependencies (lambda (package output grafts)
(match (->graft package output) (mlet %store-monad ((grafts grafts))
(#f grafts) (>>= (->graft package output)
(graft (cons graft grafts)))) (match-lambda
'() (#f (return grafts))
bag (graft (return (cons graft grafts)))))))
#:native? #f))) (return '())
'())) bag))))
;; We can end up with several identical grafts if we stumble upon packages (target-grafts
;; that are not 'eq?' but map to the same derivation (this can happen when (if target
;; using things like 'package-with-explicit-inputs'.) Hence the (let ((->graft (input-cross-graft target system)))
;; 'delete-duplicates' call. (parameterize ((%current-system system)
(delete-duplicates (%current-target-system target))
(append native-grafts target-grafts))) (fold-bag-dependencies
(lambda (package output grafts)
(mlet %store-monad ((grafts grafts))
(>>= (->graft package output)
(match-lambda
(#f (return grafts))
(graft (return (cons graft grafts)))))))
(return '())
bag
#:native? #f)))
(return '()))))
(define* (package-grafts store package ;; We can end up with several identical grafts if we stumble upon packages
#:optional (system (%current-system)) ;; that are not 'eq?' but map to the same derivation (this can happen when
#:key target) ;; using things like 'package-with-explicit-inputs'.) Hence the
;; 'delete-duplicates' call.
(return (delete-duplicates
(append native-grafts target-grafts)))))
(define* (package-grafts* package
#:optional (system (%current-system))
#:key target)
"Return the list of grafts applicable to PACKAGE as built for SYSTEM and "Return the list of grafts applicable to PACKAGE as built for SYSTEM and
TARGET." TARGET."
(let* ((package (or (package-replacement package) package)) (let* ((package (or (package-replacement package) package))
(bag (package->bag package system target))) (bag (package->bag package system target)))
(bag-grafts store bag))) (bag-grafts bag)))
(define package-grafts
(store-lower package-grafts*))
(define-inlinable (derivation=? drv1 drv2) (define-inlinable (derivation=? drv1 drv2)
"Return true if DRV1 and DRV2 are equal." "Return true if DRV1 and DRV2 are equal."
@ -1438,7 +1451,6 @@ error reporting."
;; It's possible that INPUTS contains packages that are not 'eq?' but ;; It's possible that INPUTS contains packages that are not 'eq?' but
;; that lead to the same derivation. Delete those duplicates to avoid ;; that lead to the same derivation. Delete those duplicates to avoid
;; issues down the road, such as duplicate entries in '%build-inputs'. ;; issues down the road, such as duplicate entries in '%build-inputs'.
;; TODO: Change to monadic style.
(apply (bag-build bag) (bag-name bag) (apply (bag-build bag) (bag-name bag)
(delete-duplicates input-drvs input=?) (delete-duplicates input-drvs input=?)
#:search-paths paths #:search-paths paths
@ -1488,51 +1500,57 @@ This is an internal procedure."
(define bag->derivation* (define bag->derivation*
(store-lower bag->derivation)) (store-lower bag->derivation))
(define* (package-derivation store package (define graft-derivation*
#:optional (system (%current-system)) (store-lift graft-derivation))
#:key (graft? (%graft?)))
(define* (package->derivation package
#:optional (system (%current-system))
#:key (graft? (%graft?)))
"Return the <derivation> object of PACKAGE for SYSTEM." "Return the <derivation> object of PACKAGE for SYSTEM."
;; Compute the derivation and cache the result. Caching is important ;; Compute the derivation and cache the result. Caching is important
;; because some derivations, such as the implicit inputs of the GNU build ;; because some derivations, such as the implicit inputs of the GNU build
;; system, will be queried many, many times in a row. ;; system, will be queried many, many times in a row.
(cached package (cons system graft?) (mcached (mlet* %store-monad ((bag -> (package->bag package system #f
(let* ((bag (package->bag package system #f #:graft? graft?)) #:graft? graft?))
(drv (bag->derivation* store bag package))) (drv (bag->derivation bag package)))
(if graft? (if graft?
(match (bag-grafts store bag) (>>= (bag-grafts bag)
(() (match-lambda
drv) (()
(grafts (return drv))
(let ((guile (package-derivation store (guile-for-grafts) (grafts
system #:graft? #f))) (mlet %store-monad ((guile (package->derivation
;; TODO: As an optimization, we can simply graft the tip (default-guile)
;; of the derivation graph since 'graft-derivation' system #:graft? #f)))
;; recurses anyway. (graft-derivation* drv grafts
(graft-derivation store drv grafts #:system system
#:system system #:guile guile)))))
#:guile guile)))) (return drv)))
drv)))) package system #f graft?))
(define* (package-cross-derivation store package target (define* (package->cross-derivation package target
#:optional (system (%current-system)) #:optional (system (%current-system))
#:key (graft? (%graft?))) #:key (graft? (%graft?)))
"Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
system identifying string)." system identifying string)."
(cached package (list system target graft?) (mcached (mlet* %store-monad ((bag -> (package->bag package system target
(let* ((bag (package->bag package system target #:graft? graft?)) #:graft? graft?))
(drv (bag->derivation* store bag package))) (drv (bag->derivation bag package)))
(if graft? (if graft?
(match (bag-grafts store bag) (>>= (bag-grafts bag)
(() (match-lambda
drv) (()
(grafts (return drv))
(graft-derivation store drv grafts (grafts
#:system system (mlet %store-monad ((guile (package->derivation
#:guile (default-guile)
(package-derivation store (guile-for-grafts) system #:graft? #f)))
system #:graft? #f)))) (graft-derivation* drv grafts
drv)))) #:system system
#:guile guile)))))
(return drv)))
package system target graft?))
(define* (package-output store package (define* (package-output store package
#:optional (output "out") (system (%current-system))) #:optional (output "out") (system (%current-system)))
@ -1580,11 +1598,11 @@ unless you know what you are doing."
out) out)
store)))) store))))
(define package->derivation (define package-derivation
(store-lift package-derivation)) (store-lower package->derivation))
(define package->cross-derivation (define package-cross-derivation
(store-lift package-cross-derivation)) (store-lower package->cross-derivation))
(define-gexp-compiler (package-compiler (package <package>) system target) (define-gexp-compiler (package-compiler (package <package>) system target)
;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for