[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/05: Use 'mlambda' instead of 'memoize'.
|
From: |
Ludovic Courtès |
|
Subject: |
02/05: Use 'mlambda' instead of 'memoize'. |
|
Date: |
Sat, 28 Jan 2017 17:58:59 +0000 (UTC) |
civodul pushed a commit to branch master
in repository guix.
commit 55b2d921456e888f097bf4e43a3d25b112f3e563
Author: Ludovic Courtès <address@hidden>
Date: Sat Jan 28 17:09:34 2017 +0100
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.
---
gnu/packages.scm | 31 +++++++--------
gnu/packages/bootstrap.scm | 35 ++++++++---------
guix/build-system/gnu.scm | 47 +++++++++++-----------
guix/build-system/python.scm | 85 ++++++++++++++++++++--------------------
guix/derivations.scm | 88 +++++++++++++++++++++---------------------
guix/gnu-maintenance.scm | 83 ++++++++++++++++++++-------------------
guix/modules.scm | 21 +++++-----
guix/scripts/graph.scm | 11 +++---
guix/scripts/lint.scm | 9 ++---
guix/store.scm | 9 ++---
guix/utils.scm | 9 ++---
11 files changed, 208 insertions(+), 220 deletions(-)
diff --git a/gnu/packages.scm b/gnu/packages.scm
index ec24734..0aa289d 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -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
diff --git a/gnu/packages/bootstrap.scm b/gnu/packages/bootstrap.scm
index 7cde51f..c8d94c8 100644
--- a/gnu/packages/bootstrap.scm
+++ b/gnu/packages/bootstrap.scm
@@ -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)
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index f05ddf9..730e638 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -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
diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm
index bfe0eca..383e8cb 100644
--- a/guix/build-system/python.scm
+++ b/guix/build-system/python.scm
@@ -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)
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 056b116..47a783f 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -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
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 05ea192..012f587 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -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))))))))
;;;
diff --git a/guix/modules.scm b/guix/modules.scm
index 2ff9400..8c63f21 100644
--- a/guix/modules.scm
+++ b/guix/modules.scm
@@ -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."
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 8c82d89..9804d41 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -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
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index cb64dc8..0b38aac 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -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
diff --git a/guix/store.scm b/guix/store.scm
index 491cd5a..cb3fbed 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -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."
diff --git a/guix/utils.scm b/guix/utils.scm
index 8aa2cb7..72dc068 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -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