From: "Ludovic Courtès" <ludo@gnu.org>
To: 34122@debbugs.gnu.org
Cc: rekado@elephly.net
Subject: [bug#34122] [PATCH 1/3] channels: Don't pull from the same channel more than once.
Date: Fri, 18 Jan 2019 10:53:42 +0100 [thread overview]
Message-ID: <20190118095344.12927-1-ludo@gnu.org> (raw)
In-Reply-To: <20190118092938.12208-1-ludo@gnu.org>
Previous 'channel-instance->manifest' would call
'latest-channel-derivation', which could trigger another round of
'latest-repository-commit' for no good reason.
* guix/channels.scm (resolve-dependencies): New procedure.
(channel-instance-derivations)[edges]: New variable.
[instance->derivation]: New procedure.
* tests/channels.scm (make-instance): Use 'checkout->channel-instance'
instead of 'channel-instance'.
("channel-instances->manifest"): New test.
---
guix/channels.scm | 64 ++++++++++++++++++++++++-----------
tests/channels.scm | 84 ++++++++++++++++++++++++++++++++++++++++++++--
2 files changed, 126 insertions(+), 22 deletions(-)
diff --git a/guix/channels.scm b/guix/channels.scm
index cd8a0131bd..b9ce2aa024 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -35,6 +35,7 @@
#:autoload (guix self) (whole-package make-config.scm)
#:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep
#:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
#:export (channel
channel?
channel-name
@@ -289,6 +290,34 @@ INSTANCE depends on."
#:commit (channel-instance-commit instance)
#:dependencies dependencies))
+(define (resolve-dependencies instances)
+ "Return a procedure that, given one of the elements of INSTANCES, returns
+list of instances it depends on."
+ (define channel-instance-name
+ (compose channel-name channel-instance-channel))
+
+ (define table ;map a name to an instance
+ (fold (lambda (instance table)
+ (vhash-consq (channel-instance-name instance)
+ instance table))
+ vlist-null
+ instances))
+
+ (define edges
+ (fold (lambda (instance edges)
+ (fold (lambda (channel edges)
+ (let ((name (channel-name channel)))
+ (match (vhash-assq name table)
+ ((_ . target)
+ (vhash-consq instance target edges)))))
+ edges
+ (channel-instance-dependencies instance)))
+ vlist-null
+ instances))
+
+ (lambda (instance)
+ (vhash-foldq* cons '() instance edges)))
+
(define (channel-instance-derivations instances)
"Return the list of derivations to build INSTANCES, in the same order as
INSTANCES."
@@ -310,27 +339,22 @@ INSTANCES."
(module-ref (resolve-interface '(gnu packages guile))
'guile-bytestructures)))
- (mlet %store-monad ((core (build-channel-instance core-instance)))
- (mapm %store-monad
- (lambda (instance)
- (if (eq? instance core-instance)
- (return core)
- (match (channel-instance-dependencies instance)
- (()
+ (define edges
+ (resolve-dependencies instances))
+
+ (define (instance->derivation instance)
+ (mcached (if (eq? instance core-instance)
+ (build-channel-instance instance)
+ (mlet %store-monad ((core (instance->derivation core-instance))
+ (deps (mapm %store-monad instance->derivation
+ (edges instance))))
(build-channel-instance instance
- (cons core dependencies)))
- (channels
- (mlet %store-monad ((dependencies-derivation
- (latest-channel-derivation
- ;; %default-channels is used here to
- ;; ensure that the core channel is
- ;; available for channels declared as
- ;; dependencies.
- (append channels %default-channels))))
- (build-channel-instance instance
- (cons dependencies-derivation
- (cons core dependencies))))))))
- instances)))
+ (cons core
+ (append deps
+ dependencies)))))
+ instance))
+
+ (mapm %store-monad instance->derivation instances))
(define (whole-package-for-legacy name modules)
"Return a full-blown Guix package for MODULES, a derivation that builds Guix
diff --git a/tests/channels.scm b/tests/channels.scm
index f3fc383ac3..7df1b8c5fe 100644
--- a/tests/channels.scm
+++ b/tests/channels.scm
@@ -18,9 +18,15 @@
(define-module (test-channels)
#:use-module (guix channels)
+ #:use-module (guix profiles)
#:use-module ((guix build syscalls) #:select (mkdtemp!))
#:use-module (guix tests)
+ #:use-module (guix store)
+ #:use-module ((guix grafts) #:select (%graft?))
+ #:use-module (guix derivations)
+ #:use-module (guix gexp)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-64)
#:use-module (ice-9 match))
@@ -34,8 +40,9 @@
(and spec
(with-output-to-file (string-append instance-dir "/.guix-channel")
(lambda _ (format #t "~a" spec))))
- ((@@ (guix channels) channel-instance)
- name commit instance-dir))
+ (checkout->channel-instance instance-dir
+ #:commit commit
+ #:name name))
(define instance--boring (make-instance))
(define instance--no-deps
@@ -136,4 +143,77 @@
'abc1234)))
instances))))))
+(test-assert "channel-instances->manifest"
+ ;; Compute the manifest for a graph of instances and make sure we get a
+ ;; derivation graph that mirrors the instance graph. This test also ensures
+ ;; we don't try to access Git repositores at all at this stage.
+ (let* ((spec (lambda deps
+ `(channel (version 0)
+ (dependencies
+ ,@(map (lambda (dep)
+ `(channel
+ (name ,dep)
+ (url "http://example.org")))
+ deps)))))
+ (guix (make-instance #:name 'guix))
+ (instance0 (make-instance #:name 'a))
+ (instance1 (make-instance #:name 'b #:spec (spec 'a)))
+ (instance2 (make-instance #:name 'c #:spec (spec 'b)))
+ (instance3 (make-instance #:name 'd #:spec (spec 'c 'a))))
+ (%graft? #f) ;don't try to build stuff
+
+ ;; Create 'build-self.scm' so that GUIX is recognized as the 'guix' channel.
+ (let ((source (channel-instance-checkout guix)))
+ (mkdir (string-append source "/build-aux"))
+ (call-with-output-file (string-append source
+ "/build-aux/build-self.scm")
+ (lambda (port)
+ (write '(begin
+ (use-modules (guix) (gnu packages bootstrap))
+
+ (lambda _
+ (package->derivation %bootstrap-guile)))
+ port))))
+
+ (with-store store
+ (let ()
+ (define manifest
+ (run-with-store store
+ (channel-instances->manifest (list guix
+ instance0 instance1
+ instance2 instance3))))
+
+ (define entries
+ (manifest-entries manifest))
+
+ (define (depends? drv in out)
+ ;; Return true if DRV depends on all of IN and none of OUT.
+ (let ((lst (map derivation-input-path (derivation-inputs drv)))
+ (in (map derivation-file-name in))
+ (out (map derivation-file-name out)))
+ (and (every (cut member <> lst) in)
+ (not (any (cut member <> lst) out)))))
+
+ (define (lookup name)
+ (run-with-store store
+ (lower-object
+ (manifest-entry-item
+ (manifest-lookup manifest
+ (manifest-pattern (name name)))))))
+
+ (let ((drv-guix (lookup "guix"))
+ (drv0 (lookup "a"))
+ (drv1 (lookup "b"))
+ (drv2 (lookup "c"))
+ (drv3 (lookup "d")))
+ (and (depends? drv-guix '() (list drv0 drv1 drv2 drv3))
+ (depends? drv0
+ (list) (list drv1 drv2 drv3))
+ (depends? drv1
+ (list drv0) (list drv2 drv3))
+ (depends? drv2
+ (list drv1) (list drv0 drv3))
+ (depends? drv3
+ (list drv2 drv0) (list drv1))))))))
+
(test-end "channels")
--
2.20.1
next prev parent reply other threads:[~2019-01-18 9:54 UTC|newest]
Thread overview: 5+ messages / expand[flat|nested] mbox.gz Atom feed top
2019-01-18 9:29 [bug#34122] [PATCH 0/3] Build channel modules in the corresponding Guix Ludovic Courtès
2019-01-18 9:53 ` Ludovic Courtès [this message]
2019-01-18 9:53 ` [bug#34122] [PATCH 2/3] inferior: 'gexp->derivation-in-inferior' honors EXP's load path Ludovic Courtès
2019-01-18 9:53 ` [bug#34122] [PATCH 3/3] channels: Build channel modules in an inferior Ludovic Courtès
2019-01-20 18:24 ` bug#34122: [PATCH 0/3] Build channel modules in the corresponding Guix Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20190118095344.12927-1-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=34122@debbugs.gnu.org \
--cc=rekado@elephly.net \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.