guix-bioinformatics
/
guix
mirror of http://git.savannah.gnu.org/git/guix.git
3
0
Fork 0
Code Issues Projects Releases Wiki Activity
Browse Source

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.
wip-git-https
Ludovic Courtès 5 years ago
parent
f9704f179a
commit
55b2d92145
No known key found for this signature in database GPG Key ID: 90B11993D9AEBB5
11 changed files with 208 additions and 220 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 31
      gnu/packages.scm
  2. 35
      gnu/packages/bootstrap.scm
  3. 47
      guix/build-system/gnu.scm
  4. 85
      guix/build-system/python.scm
  5. 88
      guix/derivations.scm
  6. 83
      guix/gnu-maintenance.scm
  7. 21
      guix/modules.scm
  8. 11
      guix/scripts/graph.scm
  9. 9
      guix/scripts/lint.scm
  10. 9
      guix/store.scm
  11. 9
      guix/utils.scm

31
gnu/packages.scm
View File

@ -235,28 +235,27 @@ decreasing version order."
matching)))))
(define find-newest-available-packages
(memoize
(lambda ()
"Return a vhash keyed by package names, and with
(mlambda ()
"Return a vhash keyed by package names, and with
associated values of the form
(newest-version newest-package ...)
where the preferred package is listed first."
;; FIXME: Currently, the preferred package is whichever one
;; was found last by 'fold-packages'. Find a better solution.
(fold-packages (lambda (p r)
(let ((name (package-name p))
(version (package-version p)))
(match (vhash-assoc name r)
((_ newest-so-far . pkgs)
(case (version-compare version newest-so-far)
((>) (vhash-cons name `(,version ,p) r))
((=) (vhash-cons name `(,version ,p ,@pkgs) r))
((<) r)))
(#f (vhash-cons name `(,version ,p) r)))))
vlist-null))))
;; FIXME: Currently, the preferred package is whichever one
;; was found last by 'fold-packages'. Find a better solution.
(fold-packages (lambda (p r)
(let ((name (package-name p))
(version (package-version p)))
(match (vhash-assoc name r)
((_ newest-so-far . pkgs)
(case (version-compare version newest-so-far)
((>) (vhash-cons name `(,version ,p) r))
((=) (vhash-cons name `(,version ,p ,@pkgs) r))
((<) r)))
(#f (vhash-cons name `(,version ,p) r)))))
vlist-null)))
(define (find-best-packages-by-name name version)
"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+)))
(define package-with-bootstrap-guile
(memoize
(lambda (p)
(mlambda (p)
"Return a variant of P such that all its origins are fetched with
%BOOTSTRAP-GUILE."
(define rewritten-input
(match-lambda
((name (? origin? o))
`(,name ,(bootstrap-origin o)))
((name (? package? p) sub-drvs ...)
`(,name ,(package-with-bootstrap-guile p) ,@sub-drvs))
(x x)))
((name (? origin? o))
`(,name ,(bootstrap-origin o)))
((name (? package? p) sub-drvs ...)
`(,name ,(package-with-bootstrap-guile p) ,@sub-drvs))
(x x)))
(package (inherit p)
(source (match (package-source p)
((? origin? o) (bootstrap-origin o))
(s s)))
(inputs (map rewritten-input
(package-inputs p)))
(native-inputs (map rewritten-input
(package-native-inputs p)))
(propagated-inputs (map rewritten-input
(package-propagated-inputs p)))
(replacement (and=> (package-replacement p)
package-with-bootstrap-guile))))))
(source (match (package-source p)
((? origin? o) (bootstrap-origin o))
(s s)))
(inputs (map rewritten-input
(package-inputs p)))
(native-inputs (map rewritten-input
(package-native-inputs p)))
(propagated-inputs (map rewritten-input
(package-propagated-inputs p)))
(replacement (and=> (package-replacement p)
package-with-bootstrap-guile)))))
(define* (glibc-dynamic-linker
#: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))
(define rewritten-input
(memoize
(match-lambda
((name (? package? p) sub-drv ...)
;; XXX: Check whether P's build system knows #:implicit-inputs, for
;; things like `cross-pkg-config'.
(if (eq? (package-build-system p) gnu-build-system)
(cons* name (loop p) sub-drv)
(cons* name p sub-drv)))
(x x))))
(mlambda (input)
(match input
((name (? package? p) sub-drv ...)
;; XXX: Check whether P's build system knows #:implicit-inputs, for
;; things like `cross-pkg-config'.
(if (eq? (package-build-system p) gnu-build-system)
(cons* name (loop p) sub-drv)
(cons* name p sub-drv)))
(x x))))
(package (inherit p)
(location (if (pair? loc) (source-properties->location loc) loc))
@ -393,22 +393,21 @@ packages that must not be referenced."
;;;
(define standard-cross-packages
(memoize
(lambda (target kind)
"Return the list of name/package tuples to cross-build for TARGET. KIND
(mlambda (target kind)
"Return the list of name/package tuples to cross-build for TARGET. KIND
is one of `host' or `target'."
(let* ((cross (resolve-interface '(gnu packages cross-base)))
(gcc (module-ref cross 'cross-gcc))
(binutils (module-ref cross 'cross-binutils))
(libc (module-ref cross 'cross-libc)))
(case kind
((host)
`(("cross-gcc" ,(gcc target
(binutils target)
(libc target)))
("cross-binutils" ,(binutils target))))
((target)
`(("cross-libc" ,(libc target)))))))))
(let* ((cross (resolve-interface '(gnu packages cross-base)))
(gcc (module-ref cross 'cross-gcc))
(binutils (module-ref cross 'cross-binutils))
(libc (module-ref cross 'cross-libc)))
(case kind
((host)
`(("cross-gcc" ,(gcc target
(binutils target)
(libc target)))
("cross-binutils" ,(binutils target))))
((target)
`(("cross-libc" ,(libc target))))))))
(define* (gnu-cross-build store name
#:key

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

88
guix/derivations.scm
View File

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

83
guix/gnu-maintenance.scm
View File

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

21
guix/modules.scm
View File

@ -71,18 +71,17 @@ CLAUSES."
result)))))
(define module-file-dependencies
(memoize
(lambda (file)
"Return the list of the names of modules that the Guile module in FILE
(mlambda (file)
"Return the list of the names of modules that the Guile module in FILE
depends on."
(call-with-input-file file
(lambda (port)
(match (read port)
(('define-module name clauses ...)
(extract-dependencies clauses))
;; XXX: R6RS 'library' form is ignored.
(_
'())))))))
(call-with-input-file file
(lambda (port)
(match (read port)
(('define-module name clauses ...)
(extract-dependencies clauses))
;; XXX: R6RS 'library' form is ignored.
(_
'()))))))
(define (module-name->file-name 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))))
(define standard-package-set
(memoize
(lambda ()
"Return the set of standard packages provided by GNU-BUILD-SYSTEM."
(match (standard-packages)
(((labels packages . output) ...)
(list->setq packages))))))
(mlambda ()
"Return the set of standard packages provided by GNU-BUILD-SYSTEM."
(match (standard-packages)
(((labels packages . output) ...)
(list->setq packages)))))
(define (bag-node-edges-sans-bootstrap thing)
"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)))
(define official-gnu-packages*
(memoize
(lambda ()
"A memoizing version of 'official-gnu-packages' that returns the empty
(mlambda ()
"A memoizing version of 'official-gnu-packages' that returns the empty
list when something goes wrong, such as a networking issue."
(let ((gnus (false-if-exception (official-gnu-packages))))
(or gnus '())))))
(let ((gnus (false-if-exception (official-gnu-packages))))
(or gnus '()))))
(define (check-gnu-synopsis+description package)
"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*
;; The substituter makes repeated calls to 'store-path-hash-part', hence
;; this optimization.
(memoize
(lambda (store)
"Return a regexp matching a file in STORE."
(make-regexp (string-append "^" (regexp-quote store)
"/([0-9a-df-np-sv-z]{32})-([^/]+)$")))))
(mlambda (store)
"Return a regexp matching a file in STORE."
(make-regexp (string-append "^" (regexp-quote store)
"/([0-9a-df-np-sv-z]{32})-([^/]+)$"))))
(define (store-path-package-name path)
"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
(define location
(memoize
(lambda (file line column)
"Return the <location> object for the given FILE, LINE, and COLUMN."
(and line column file
(make-location file line column)))))
(mlambda (file line column)
"Return the <location> object for the given FILE, LINE, and COLUMN."
(and line column file
(make-location file line column))))
(define (source-properties->location loc)
"Return a location object based on the info in LOC, an alist as returned

Write Preview
Loading…
Cancel
Save