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

Use 'mlambda' instead of 'memoize'. 

* gnu/packages.scm (find-newest-available-packages): Use 'mlambda'
instead of (memoize (lambda ...) ...).
* gnu/packages/bootstrap.scm (package-with-bootstrap-guile): Likewise.
* guix/build-system/gnu.scm (package-with-explicit-inputs)[rewritten-input]:
Likewise.
* guix/build-system/python.scm (package-with-explicit-python)[transform]:
Likewise.
* guix/derivations.scm (derivation->string): Likewise.
* guix/gnu-maintenance.scm (gnu-package?): Likewise.
* guix/modules.scm (module-file-dependencies): Likewise.
* guix/scripts/graph.scm (standard-package-set): Likewise.
* guix/scripts/lint.scm (official-gnu-packages*): Likewise.
* guix/store.scm (store-regexp*): Likewise.
* guix/utils.scm (location): Likewise.
This commit is contained in:
Ludovic Courtès 2017-01-28 17:09:34 +01:00
parent f9704f179a
commit 55b2d92145
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
11 changed files with 204 additions and 216 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
gnu/packages.scm
View File

@ -235,28 +235,27 @@ decreasing version order."
matching))))) matching)))))
(define find-newest-available-packages (define find-newest-available-packages
(memoize (mlambda ()
(lambda () "Return a vhash keyed by package names, and with
"Return a vhash keyed by package names, and with
associated values of the form associated values of the form
(newest-version newest-package ...) (newest-version newest-package ...)
where the preferred package is listed first." where the preferred package is listed first."
;; FIXME: Currently, the preferred package is whichever one ;; FIXME: Currently, the preferred package is whichever one
;; was found last by 'fold-packages'. Find a better solution. ;; was found last by 'fold-packages'. Find a better solution.
(fold-packages (lambda (p r) (fold-packages (lambda (p r)
(let ((name (package-name p)) (let ((name (package-name p))
(version (package-version p))) (version (package-version p)))
(match (vhash-assoc name r) (match (vhash-assoc name r)
((_ newest-so-far . pkgs) ((_ newest-so-far . pkgs)
(case (version-compare version newest-so-far) (case (version-compare version newest-so-far)
((>) (vhash-cons name `(,version ,p) r)) ((>) (vhash-cons name `(,version ,p) r))
((=) (vhash-cons name `(,version ,p ,@pkgs) r)) ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
((<) r))) ((<) r)))
(#f (vhash-cons name `(,version ,p) r))))) (#f (vhash-cons name `(,version ,p) r)))))
vlist-null)))) vlist-null)))
(define (find-best-packages-by-name name version) (define (find-best-packages-by-name name version)
"If version is #f, return the list of packages named NAME with the highest "If version is #f, return the list of packages named NAME with the highest

35
gnu/packages/bootstrap.scm
View File

@ -131,30 +131,29 @@ successful, or false to signal an error."
(license gpl3+))) (license gpl3+)))
(define package-with-bootstrap-guile (define package-with-bootstrap-guile
(memoize (mlambda (p)
(lambda (p)
"Return a variant of P such that all its origins are fetched with "Return a variant of P such that all its origins are fetched with
%BOOTSTRAP-GUILE." %BOOTSTRAP-GUILE."
(define rewritten-input (define rewritten-input
(match-lambda (match-lambda
((name (? origin? o)) ((name (? origin? o))
`(,name ,(bootstrap-origin o))) `(,name ,(bootstrap-origin o)))
((name (? package? p) sub-drvs ...) ((name (? package? p) sub-drvs ...)
`(,name ,(package-with-bootstrap-guile p) ,@sub-drvs)) `(,name ,(package-with-bootstrap-guile p) ,@sub-drvs))
(x x))) (x x)))
(package (inherit p) (package (inherit p)
(source (match (package-source p) (source (match (package-source p)
((? origin? o) (bootstrap-origin o)) ((? origin? o) (bootstrap-origin o))
(s s))) (s s)))
(inputs (map rewritten-input (inputs (map rewritten-input
(package-inputs p))) (package-inputs p)))
(native-inputs (map rewritten-input (native-inputs (map rewritten-input
(package-native-inputs p))) (package-native-inputs p)))
(propagated-inputs (map rewritten-input (propagated-inputs (map rewritten-input
(package-propagated-inputs p))) (package-propagated-inputs p)))
(replacement (and=> (package-replacement p) (replacement (and=> (package-replacement p)
package-with-bootstrap-guile)))))) package-with-bootstrap-guile)))))
(define* (glibc-dynamic-linker (define* (glibc-dynamic-linker
#:optional (system (or (and=> (%current-target-system) #:optional (system (or (and=> (%current-target-system)

47
guix/build-system/gnu.scm
View File

@ -84,15 +84,15 @@ builder, or the distro's final Guile when GUILE is #f."
(let loop ((p p)) (let loop ((p p))
(define rewritten-input (define rewritten-input
(memoize (mlambda (input)
(match-lambda (match input
((name (? package? p) sub-drv ...) ((name (? package? p) sub-drv ...)
;; XXX: Check whether P's build system knows #:implicit-inputs, for ;; XXX: Check whether P's build system knows #:implicit-inputs, for
;; things like `cross-pkg-config'. ;; things like `cross-pkg-config'.
(if (eq? (package-build-system p) gnu-build-system) (if (eq? (package-build-system p) gnu-build-system)
(cons* name (loop p) sub-drv) (cons* name (loop p) sub-drv)
(cons* name p sub-drv))) (cons* name p sub-drv)))
(x x)))) (x x))))
(package (inherit p) (package (inherit p)
(location (if (pair? loc) (source-properties->location loc) loc)) (location (if (pair? loc) (source-properties->location loc) loc))
@ -393,22 +393,21 @@ packages that must not be referenced."
;;; ;;;
(define standard-cross-packages (define standard-cross-packages
(memoize (mlambda (target kind)
(lambda (target kind) "Return the list of name/package tuples to cross-build for TARGET. KIND
"Return the list of name/package tuples to cross-build for TARGET. KIND
is one of `host' or `target'." is one of `host' or `target'."
(let* ((cross (resolve-interface '(gnu packages cross-base))) (let* ((cross (resolve-interface '(gnu packages cross-base)))
(gcc (module-ref cross 'cross-gcc)) (gcc (module-ref cross 'cross-gcc))
(binutils (module-ref cross 'cross-binutils)) (binutils (module-ref cross 'cross-binutils))
(libc (module-ref cross 'cross-libc))) (libc (module-ref cross 'cross-libc)))
(case kind (case kind
((host) ((host)
`(("cross-gcc" ,(gcc target `(("cross-gcc" ,(gcc target
(binutils target) (binutils target)
(libc target))) (libc target)))
("cross-binutils" ,(binutils target)))) ("cross-binutils" ,(binutils target))))
((target) ((target)
`(("cross-libc" ,(libc target))))))))) `(("cross-libc" ,(libc target))))))))
(define* (gnu-cross-build store name (define* (gnu-cross-build store name
#:key #:key

81
guix/build-system/python.scm
View File

@ -87,49 +87,48 @@ pre-defined variants."
;; Memoize the transformations. Failing to do that, we would build a huge ;; Memoize the transformations. Failing to do that, we would build a huge
;; object graph with lots of duplicates, which in turns prevents us from ;; object graph with lots of duplicates, which in turns prevents us from
;; benefiting from memoization in 'package-derivation'. ;; benefiting from memoization in 'package-derivation'.
(memoize ;FIXME: use 'eq?' (mlambda (p) ;XXX: use 'eq?'
(lambda (p) (let* ((rewrite-if-package
(let* ((rewrite-if-package (lambda (content)
(lambda (content) ;; CONTENT may be a file name, in which case it is returned,
;; CONTENT may be a file name, in which case it is returned, ;; or a package, which is rewritten with the new PYTHON and
;; or a package, which is rewritten with the new PYTHON and ;; NEW-PREFIX.
;; NEW-PREFIX. (if (package? content)
(if (package? content) (transform content)
(transform content) content)))
content))) (rewrite
(rewrite (match-lambda
(match-lambda ((name content . rest)
((name content . rest) (append (list name (rewrite-if-package content)) rest)))))
(append (list name (rewrite-if-package content)) rest)))))
(cond (cond
;; If VARIANT-PROPERTY is present, use that. ;; If VARIANT-PROPERTY is present, use that.
((and variant-property ((and variant-property
(assoc-ref (package-properties p) variant-property)) (assoc-ref (package-properties p) variant-property))
=> force) => force)
;; Otherwise build the new package object graph. ;; Otherwise build the new package object graph.
((eq? (package-build-system p) python-build-system) ((eq? (package-build-system p) python-build-system)
(package (package
(inherit p) (inherit p)
(location (package-location p)) (location (package-location p))
(name (let ((name (package-name p))) (name (let ((name (package-name p)))
(string-append new-prefix (string-append new-prefix
(if (string-prefix? old-prefix name) (if (string-prefix? old-prefix name)
(substring name (substring name
(string-length old-prefix)) (string-length old-prefix))
name)))) name))))
(arguments (arguments
(let ((python (if (promise? python) (let ((python (if (promise? python)
(force python) (force python)
python))) python)))
(ensure-keyword-arguments (package-arguments p) (ensure-keyword-arguments (package-arguments p)
`(#:python ,python)))) `(#:python ,python))))
(inputs (map rewrite (package-inputs p))) (inputs (map rewrite (package-inputs p)))
(propagated-inputs (map rewrite (package-propagated-inputs p))) (propagated-inputs (map rewrite (package-propagated-inputs p)))
(native-inputs (map rewrite (package-native-inputs p))))) (native-inputs (map rewrite (package-native-inputs p)))))
(else (else
p)))))) p)))))
transform) transform)

88
guix/derivations.scm
View File

@ -557,12 +557,11 @@ that form."
(display ")" port)))) (display ")" port))))
(define derivation->string (define derivation->string
(memoize (mlambda (drv)
(lambda (drv) "Return the external representation of DRV as a string."
"Return the external representation of DRV as a string." (with-fluids ((%default-port-encoding "UTF-8"))
(with-fluids ((%default-port-encoding "UTF-8")) (call-with-output-string
(call-with-output-string (cut write-derivation drv <>)))))
(cut write-derivation drv <>))))))
(define* (derivation->output-path drv #:optional (output "out")) (define* (derivation->output-path drv #:optional (output "out"))
"Return the store path of its output OUTPUT. Raise a "Return the store path of its output OUTPUT. Raise a
@ -584,12 +583,14 @@ DRV."
(define derivation-path->output-path (define derivation-path->output-path
;; This procedure is called frequently, so memoize it. ;; This procedure is called frequently, so memoize it.
(memoize (let ((memoized (mlambda (path output)
(lambda* (path #:optional (output "out")) (derivation->output-path (call-with-input-file path
"Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store read-derivation)
output))))
(lambda* (path #:optional (output "out"))
"Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store
path of its output OUTPUT." path of its output OUTPUT."
(derivation->output-path (call-with-input-file path read-derivation) (memoized path output))))
output))))
(define (derivation-path->output-paths path) (define (derivation-path->output-paths path)
"Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the
@ -616,23 +617,21 @@ in SIZE bytes."
(loop (+ 1 i)))))) (loop (+ 1 i))))))
(define derivation-path->base16-hash (define derivation-path->base16-hash
(memoize (mlambda (file)
(lambda (file) "Return a string containing the base16 representation of the hash of the
"Return a string containing the base16 representation of the hash of the
derivation at FILE." derivation at FILE."
(call-with-input-file file (call-with-input-file file
(compose bytevector->base16-string (compose bytevector->base16-string
derivation-hash derivation-hash
read-derivation))))) read-derivation))))
(define derivation-hash ; `hashDerivationModulo' in derivations.cc (define derivation-hash ; `hashDerivationModulo' in derivations.cc
(memoize (mlambda (drv)
(lambda (drv)
"Return the hash of DRV, modulo its fixed-output inputs, as a bytevector." "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector."
(match drv (match drv
(($ <derivation> ((_ . ($ <derivation-output> path (($ <derivation> ((_ . ($ <derivation-output> path
(? symbol? hash-algo) (? bytevector? hash) (? symbol? hash-algo) (? bytevector? hash)
(? boolean? recursive?))))) (? boolean? recursive?)))))
;; A fixed-output derivation. ;; A fixed-output derivation.
(sha256 (sha256
(string->utf8 (string->utf8
@ -642,14 +641,14 @@ derivation at FILE."
":" (bytevector->base16-string hash) ":" (bytevector->base16-string hash)
":" path)))) ":" path))))
(($ <derivation> outputs inputs sources (($ <derivation> outputs inputs sources
system builder args env-vars) system builder args env-vars)
;; A regular derivation: replace the path of each input with that ;; A regular derivation: replace the path of each input with that
;; input's hash; return the hash of serialization of the resulting ;; input's hash; return the hash of serialization of the resulting
;; derivation. ;; derivation.
(let* ((inputs (map (match-lambda (let* ((inputs (map (match-lambda
(($ <derivation-input> path sub-drvs) (($ <derivation-input> path sub-drvs)
(let ((hash (derivation-path->base16-hash path))) (let ((hash (derivation-path->base16-hash path)))
(make-derivation-input hash sub-drvs)))) (make-derivation-input hash sub-drvs))))
inputs)) inputs))
(drv (make-derivation outputs (drv (make-derivation outputs
(sort (coalesce-duplicate-inputs inputs) (sort (coalesce-duplicate-inputs inputs)
@ -662,7 +661,7 @@ derivation at FILE."
;; the SHA256 port's `write' method gets called for every single ;; the SHA256 port's `write' method gets called for every single
;; character. ;; character.
(sha256 (sha256
(string->utf8 (derivation->string drv))))))))) (string->utf8 (derivation->string drv))))))))
(define (store-path type hash name) ; makeStorePath (define (store-path type hash name) ; makeStorePath
"Return the store path for NAME/HASH/TYPE." "Return the store path for NAME/HASH/TYPE."
@ -916,18 +915,17 @@ recursively."
(define rewritten-input (define rewritten-input
;; Rewrite the given input according to MAPPING, and return an input ;; Rewrite the given input according to MAPPING, and return an input
;; in the format used in 'derivation' calls. ;; in the format used in 'derivation' calls.
(memoize (mlambda (input loop)
(lambda (input loop) (match input
(match input (($ <derivation-input> path (sub-drvs ...))
(($ <derivation-input> path (sub-drvs ...)) (match (vhash-assoc path mapping)
(match (vhash-assoc path mapping) ((_ . (? derivation? replacement))
((_ . (? derivation? replacement)) (cons replacement sub-drvs))
(cons replacement sub-drvs)) ((_ . replacement)
((_ . replacement) (list replacement))
(list replacement)) (#f
(#f (let* ((drv (loop (call-with-input-file path read-derivation))))
(let* ((drv (loop (call-with-input-file path read-derivation)))) (cons drv sub-drvs))))))))
(cons drv sub-drvs)))))))))
(let loop ((drv drv)) (let loop ((drv drv))
(let* ((inputs (map (cut rewritten-input <> loop) (let* ((inputs (map (cut rewritten-input <> loop)
@ -1058,13 +1056,13 @@ system, imported, and appears under FINAL-PATH in the resulting store path."
(define search-path* (define search-path*
;; A memoizing version of 'search-path' so 'imported-modules' does not end ;; A memoizing version of 'search-path' so 'imported-modules' does not end
;; up looking for the same files over and over again. ;; up looking for the same files over and over again.
(memoize (lambda (path file) (mlambda (path file)
"Search for FILE in PATH and memoize the result. Raise a "Search for FILE in PATH and memoize the result. Raise a
'&file-search-error' condition if it could not be found." '&file-search-error' condition if it could not be found."
(or (search-path path file) (or (search-path path file)
(raise (condition (raise (condition
(&file-search-error (file file) (&file-search-error (file file)
(path path)))))))) (path path)))))))
(define (module->source-file-name module) (define (module->source-file-name module)
"Return the file name corresponding to MODULE, a Guile module name (a list "Return the file name corresponding to MODULE, a Guile module name (a list

79
guix/gnu-maintenance.scm
View File

@ -165,49 +165,48 @@ found."
(official-gnu-packages))) (official-gnu-packages)))
(define gnu-package? (define gnu-package?
(memoize (let ((official-gnu-packages (memoize official-gnu-packages)))
(let ((official-gnu-packages (memoize official-gnu-packages))) (mlambda (package)
(lambda (package) "Return true if PACKAGE is a GNU package. This procedure may access the
"Return true if PACKAGE is a GNU package. This procedure may access the
network to check in GNU's database." network to check in GNU's database."
(define (mirror-type url) (define (mirror-type url)
(let ((uri (string->uri url))) (let ((uri (string->uri url)))
(and (eq? (uri-scheme uri) 'mirror) (and (eq? (uri-scheme uri) 'mirror)
(cond (cond
((member (uri-host uri) ((member (uri-host uri)
'("gnu" "gnupg" "gcc" "gnome")) '("gnu" "gnupg" "gcc" "gnome"))
;; Definitely GNU. ;; Definitely GNU.
'gnu) 'gnu)
((equal? (uri-host uri) "cran") ((equal? (uri-host uri) "cran")
;; Possibly GNU: mirror://cran could be either GNU R itself ;; Possibly GNU: mirror://cran could be either GNU R itself
;; or a non-GNU package. ;; or a non-GNU package.
#f) #f)
(else (else
;; Definitely non-GNU. ;; Definitely non-GNU.
'non-gnu))))) 'non-gnu)))))
(define (gnu-home-page? package) (define (gnu-home-page? package)
(letrec-syntax ((>> (syntax-rules () (letrec-syntax ((>> (syntax-rules ()
((_ value proc) ((_ value proc)
(and=> value proc)) (and=> value proc))
((_ value proc rest ...) ((_ value proc rest ...)
(and=> value (and=> value
(lambda (next) (lambda (next)
(>> (proc next) rest ...))))))) (>> (proc next) rest ...)))))))
(>> package package-home-page (>> package package-home-page
string->uri uri-host string->uri uri-host
(lambda (host) (lambda (host)
(member host '("www.gnu.org" "gnu.org")))))) (member host '("www.gnu.org" "gnu.org"))))))
(or (gnu-home-page? package) (or (gnu-home-page? package)
(let ((url (and=> (package-source package) origin-uri)) (let ((url (and=> (package-source package) origin-uri))
(name (package-upstream-name package))) (name (package-upstream-name package)))
(case (and (string? url) (mirror-type url)) (case (and (string? url) (mirror-type url))
((gnu) #t) ((gnu) #t)
((non-gnu) #f) ((non-gnu) #f)
(else (else
(and (member name (map gnu-package-name (official-gnu-packages))) (and (member name (map gnu-package-name (official-gnu-packages)))
#t))))))))) #t))))))))
;;; ;;;

21
guix/modules.scm
View File

@ -71,18 +71,17 @@ CLAUSES."
result))))) result)))))
(define module-file-dependencies (define module-file-dependencies
(memoize (mlambda (file)
(lambda (file) "Return the list of the names of modules that the Guile module in FILE
"Return the list of the names of modules that the Guile module in FILE
depends on." depends on."
(call-with-input-file file (call-with-input-file file
(lambda (port) (lambda (port)
(match (read port) (match (read port)
(('define-module name clauses ...) (('define-module name clauses ...)
(extract-dependencies clauses)) (extract-dependencies clauses))
;; XXX: R6RS 'library' form is ignored. ;; XXX: R6RS 'library' form is ignored.
(_ (_
'()))))))) '()))))))
(define (module-name->file-name module) (define (module-name->file-name module)
"Return the file name for MODULE." "Return the file name for MODULE."

11
guix/scripts/graph.scm
View File

@ -191,12 +191,11 @@ Dependencies may include packages, origin, and file names."
%store-monad)))) %store-monad))))
(define standard-package-set (define standard-package-set
(memoize (mlambda ()
(lambda () "Return the set of standard packages provided by GNU-BUILD-SYSTEM."
"Return the set of standard packages provided by GNU-BUILD-SYSTEM." (match (standard-packages)
(match (standard-packages) (((labels packages . output) ...)
(((labels packages . output) ...) (list->setq packages)))))
(list->setq packages))))))
(define (bag-node-edges-sans-bootstrap thing) (define (bag-node-edges-sans-bootstrap thing)
"Like 'bag-node-edges', but pretend that the standard packages of "Like 'bag-node-edges', but pretend that the standard packages of

9
guix/scripts/lint.scm
View File

@ -559,12 +559,11 @@ patch could not be found."
str))) str)))
(define official-gnu-packages* (define official-gnu-packages*
(memoize (mlambda ()
(lambda () "A memoizing version of 'official-gnu-packages' that returns the empty
"A memoizing version of 'official-gnu-packages' that returns the empty
list when something goes wrong, such as a networking issue." list when something goes wrong, such as a networking issue."
(let ((gnus (false-if-exception (official-gnu-packages)))) (let ((gnus (false-if-exception (official-gnu-packages))))
(or gnus '()))))) (or gnus '()))))
(define (check-gnu-synopsis+description package) (define (check-gnu-synopsis+description package)
"Make sure that, if PACKAGE is a GNU package, it uses the synopsis and "Make sure that, if PACKAGE is a GNU package, it uses the synopsis and

9
guix/store.scm
View File

@ -1282,11 +1282,10 @@ valid inputs."
(define store-regexp* (define store-regexp*
;; The substituter makes repeated calls to 'store-path-hash-part', hence ;; The substituter makes repeated calls to 'store-path-hash-part', hence
;; this optimization. ;; this optimization.
(memoize (mlambda (store)
(lambda (store) "Return a regexp matching a file in STORE."
"Return a regexp matching a file in STORE." (make-regexp (string-append "^" (regexp-quote store)
(make-regexp (string-append "^" (regexp-quote store) "/([0-9a-df-np-sv-z]{32})-([^/]+)$"))))
"/([0-9a-df-np-sv-z]{32})-([^/]+)$")))))
(define (store-path-package-name path) (define (store-path-package-name path)
"Return the package name part of PATH, a file name in the store." "Return the package name part of PATH, a file name in the store."

9
guix/utils.scm
View File

@ -771,11 +771,10 @@ be determined."
(column location-column)) ; 0-indexed column (column location-column)) ; 0-indexed column
(define location (define location
(memoize (mlambda (file line column)
(lambda (file line column) "Return the <location> object for the given FILE, LINE, and COLUMN."
"Return the <location> object for the given FILE, LINE, and COLUMN." (and line column file
(and line column file (make-location file line column))))
(make-location file line column)))))
(define (source-properties->location loc) (define (source-properties->location loc)
"Return a location object based on the info in LOC, an alist as returned "Return a location object based on the info in LOC, an alist as returned