[PATCH 0/2] gexp: Add 'let-system'

  • Done
  • quality assurance status badge
Details
5 participants
  • Danny Milosavljevic
  • Ludovic Courtès
  • Mathieu Othacehe
  • Marius Bakke
  • Mathieu Othacehe
Owner
unassigned
Submitted by
Ludovic Courtès
Severity
normal
L
L
Ludovic Courtès wrote on 14 Nov 2017 17:18
(address . guix-patches@gnu.org)
20171114161841.8485-1-ludo@gnu.org
Hello!

This patch adds the ‘let-system’ form to (guix gexp), as discussed with
Mathieu at https://bugs.gnu.org/29281. It allows you to insert
system-dependent code inside a gexp, as in this example:

#~(system*
#+(let-system system
(cond ((string-prefix? "armhf-" system)
(file-append qemu "/bin/qemu-system-arm"))
((string-prefix? "x86_64-" system)
(file-append qemu "/bin/qemu-system-x86_64"))
(else
(error "dunno!"))))
"-net" "user" #$image)

(Using (%current-system) and (%current-target-system) does *not* achieve
this, in case you’re wondering, because at the time the gexp is defined
they carry their default value.)

Feedback welcome!

Ludo’.

Ludovic Courtès (2):
gexp: Compilers can now return lowerable objects.
gexp: Add 'let-system'.

doc/guix.texi | 26 ++++++++++++++
guix/gexp.scm | 105 ++++++++++++++++++++++++++++++++++++++++++++++++---------
tests/gexp.scm | 50 +++++++++++++++++++++++++++
3 files changed, 165 insertions(+), 16 deletions(-)

--
2.15.0
L
L
Ludovic Courtès wrote on 14 Nov 2017 17:25
[PATCH 1/2] gexp: Compilers can now return lowerable objects.
(address . 29296@debbugs.gnu.org)
20171114162515.8743-1-ludo@gnu.org
* guix/gexp.scm (lower-object): Iterate if LOWERED is a struct.
(lower+expand-object): New procedure.
(gexp->sexp): Use it.
(define-gexp-compiler): Adjust docstring.
---
guix/gexp.scm | 54 +++++++++++++++++++++++++++++++++++++++---------------
1 file changed, 39 insertions(+), 15 deletions(-)

Toggle diff (83 lines)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index b9525603e..c2d942c7f 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -195,24 +195,50 @@ procedure to expand it; otherwise return #f."
corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true.
OBJ must be an object that has an associated gexp compiler, such as a
<package>."
- (match (lookup-compiler obj)
- (#f
- (raise (condition (&gexp-input-error (input obj)))))
- (lower
- (lower obj system target))))
+ (let loop ((obj obj))
+ (match (lookup-compiler obj)
+ (#f
+ (raise (condition (&gexp-input-error (input obj)))))
+ (lower
+ (mlet %store-monad ((lowered (lower obj system target)))
+ (if (and (struct? lowered) (not (eq? lowered obj)))
+ (loop lowered)
+ (return lowered)))))))
+
+(define* (lower+expand-object obj
+ #:optional (system (%current-system))
+ #:key target (output "out"))
+ "Return as a value in %STORE-MONAD the output of object OBJ expands to for
+SYSTEM and TARGET. Object such as <package>, <file-append>, or <plain-file>
+expand to file names, but it's possible to expand to a plain data type."
+ (let loop ((obj obj)
+ (expand (and (struct? obj) (lookup-expander obj))))
+ (match (lookup-compiler obj)
+ (#f
+ (raise (condition (&gexp-input-error (input obj)))))
+ (lower
+ (mlet %store-monad ((lowered (lower obj system target)))
+ ;; LOWER might return something that needs to be further lowered.
+ (if (struct? lowered)
+ ;; If we lack an expander, delegate to that of LOWERED.
+ (if (not expand)
+ (loop lowered (lookup-expander lowered))
+ (return (expand obj lowered output)))
+ (return lowered))))))) ;lists, vectors, etc.
(define-syntax define-gexp-compiler
(syntax-rules (=> compiler expander)
"Define NAME as a compiler for objects matching PREDICATE encountered in
gexps.
-In the simplest form of the macro, BODY must return a derivation for PARAM, an
-object that matches PREDICATE, for SYSTEM and TARGET (the latter of which is
-#f except when cross-compiling.)
+In the simplest form of the macro, BODY must return (1) a derivation for
+a record of the specified type, for SYSTEM and TARGET (the latter of which is
+#f except when cross-compiling), (2) another record that can itself be
+compiled down to a derivation, or (3) an object of a primitive data type.
The more elaborate form allows you to specify an expander:
- (define-gexp-compiler something something?
+ (define-gexp-compiler something-compiler <something>
compiler => (lambda (param system target) ...)
expander => (lambda (param drv output) ...))
@@ -795,12 +821,10 @@ and in the current monad setting (system type, etc.)"
(or n? native?)))
refs)))
(($ <gexp-input> (? struct? thing) output n?)
- (let ((target (if (or n? native?) #f target))
- (expand (lookup-expander thing)))
- (mlet %store-monad ((obj (lower-object thing system
- #:target target)))
- ;; OBJ must be either a derivation or a store file name.
- (return (expand thing obj output)))))
+ (let ((target (if (or n? native?) #f target)))
+ (lower+expand-object thing system
+ #:target target
+ #:output output)))
(($ <gexp-input> x)
(return x))
(x
--
2.15.0
L
L
Ludovic Courtès wrote on 14 Nov 2017 17:25
[PATCH 2/2] gexp: Add 'let-system'.
(address . 29296@debbugs.gnu.org)
20171114162515.8743-2-ludo@gnu.org
* guix/gexp.scm (<system-binding>): New record type.
(let-system): New macro.
(system-binding-compiler): New procedure.
(default-expander): Add catch-all case.
* tests/gexp.scm ("let-system", "let-system, target")
("let-system, ungexp-native, target")
("let-system, nested"): New tests.
* doc/guix.texi (G-Expressions): Document it.
---
doc/guix.texi | 26 ++++++++++++++++++++++++++
guix/gexp.scm | 51 ++++++++++++++++++++++++++++++++++++++++++++++++++-
tests/gexp.scm | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++
3 files changed, 126 insertions(+), 1 deletion(-)

Toggle diff (176 lines)
diff --git a/doc/guix.texi b/doc/guix.texi
index 098ff5e54..0e795ada6 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4799,6 +4799,32 @@ procedures called from @var{body}@dots{}.
Return @code{#t} if @var{obj} is a G-expression.
@end deffn
+@deffn {Scheme Syntax} let-system @var{system} @var{body}@dots{}
+@deffnx {Scheme Syntax} let-system (@var{system} @var{target}) @var{body}@dots{}
+Bind @var{system} to the currently targeted system---e.g.,
+@code{"x86_64-linux"}---within @var{body}.
+
+In the second case, additionally bind @var{target} to the current
+cross-compilation target---a GNU triplet such as
+@code{"arm-linux-gnueabihf"}---or @code{#f} if we are not
+cross-compiling.
+
+@code{let-system} is useful in the occasional case where the object
+spliced into the gexp depends on the target system, as in this example:
+
+@example
+#~(system*
+ #+(let-system system
+ (cond ((string-prefix? "armhf-" system)
+ (file-append qemu "/bin/qemu-system-arm"))
+ ((string-prefix? "x86_64-" system)
+ (file-append qemu "/bin/qemu-system-x86_64"))
+ (else
+ (error "dunno!"))))
+ "-net" "user" #$image)
+@end example
+@end deffn
+
G-expressions are meant to be written to disk, either as code building
some derivation, or as plain files in the store. The monadic procedures
below allow you to do that (@pxref{The Store Monad}, for more
diff --git a/guix/gexp.scm b/guix/gexp.scm
index c2d942c7f..c65c6e5f3 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -32,6 +32,7 @@
#:export (gexp
gexp?
with-imported-modules
+ let-system
gexp-input
gexp-input?
@@ -169,7 +170,9 @@ returns its output file name of OBJ's OUTPUT."
((? derivation? drv)
(derivation->output-path drv output))
((? string? file)
- file)))
+ file)
+ (obj ;lists, vectors, etc.
+ obj)))
(define (register-compiler! compiler)
"Register COMPILER as a gexp compiler."
@@ -262,6 +265,52 @@ The expander specifies how an object is converted to its sexp representation."
(return drv)))
+;;;
+;;; System dependencies.
+;;;
+
+;; Binding form for the current system and cross-compilation target.
+(define-record-type <system-binding>
+ (system-binding proc)
+ system-binding?
+ (proc system-binding-proc))
+
+(define-syntax let-system
+ (syntax-rules ()
+ "Introduce a system binding in a gexp. The simplest form is:
+
+ (let-system system
+ (cond ((string=? system \"x86_64-linux\") ...)
+ (else ...)))
+
+which binds SYSTEM to the currently targeted system. The second form is
+similar, but it also shows the cross-compilation target:
+
+ (let-system (system target)
+ ...)
+
+Here TARGET is bound to the cross-compilation triplet or #f."
+ ((_ (system target) exp0 exp ...)
+ (system-binding (lambda (system target)
+ exp0 exp ...)))
+ ((_ system exp0 exp ...)
+ (system-binding (lambda (system target)
+ exp0 exp ...)))))
+
+(define-gexp-compiler system-binding-compiler <system-binding>
+ compiler => (lambda (binding system target)
+ (match binding
+ (($ <system-binding> proc)
+ (with-monad %store-monad
+ ;; PROC is expected to return a lowerable object.
+ ;; 'lower-object' takes care of residualizing it to a
+ ;; derivation or similar.
+ (return (proc system target))))))
+
+ ;; Delegate to the expander of the object returned by PROC.
+ expander => #f)
+
+
;;;
;;; File declarations.
;;;
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 5873abdd4..f98d1e70e 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -258,6 +258,56 @@
(((thing "out"))
(eq? thing file))))))
+(test-equal "let-system"
+ (list `(begin ,(%current-system) #t) '(system-binding) '())
+ (let ((exp #~(begin
+ #$(let-system system system)
+ #t)))
+ (list (gexp->sexp* exp)
+ (match (gexp-inputs exp)
+ (((($ (@@ (guix gexp) <system-binding>)) "out"))
+ '(system-binding))
+ (x x))
+ (gexp-native-inputs exp))))
+
+(test-equal "let-system, target"
+ (list `(list ,(%current-system) #f)
+ `(list ,(%current-system) "aarch64-linux-gnu"))
+ (let ((exp #~(list #$@(let-system (system target)
+ (list system target)))))
+ (list (gexp->sexp* exp)
+ (gexp->sexp* exp "aarch64-linux-gnu"))))
+
+(test-equal "let-system, ungexp-native, target"
+ `(here it is: ,(%current-system) #f)
+ (let ((exp #~(here it is: #+@(let-system (system target)
+ (list system target)))))
+ (gexp->sexp* exp "aarch64-linux-gnu")))
+
+(test-equal "let-system, nested"
+ (list `(system* ,(string-append "qemu-system-" (%current-system))
+ "-m" "256")
+ '()
+ '(system-binding))
+ (let ((exp #~(system*
+ #+(let-system (system target)
+ (file-append (@@ (gnu packages virtualization)
+ qemu)
+ "/bin/qemu-system-"
+ system))
+ "-m" "256")))
+ (list (match (gexp->sexp* exp)
+ (('system* command rest ...)
+ `(system* ,(and (string-prefix? (%store-prefix) command)
+ (basename command))
+ ,@rest))
+ (x x))
+ (gexp-inputs exp)
+ (match (gexp-native-inputs exp)
+ (((($ (@@ (guix gexp) <system-binding>)) "out"))
+ '(system-binding))
+ (x x)))))
+
(test-assert "ungexp + ungexp-native"
(let* ((exp (gexp (list (ungexp-native %bootstrap-guile)
(ungexp coreutils)
--
2.15.0
M
M
Mathieu Othacehe wrote on 15 Nov 2017 12:27
(name . Ludovic Courtès)(address . ludo@gnu.org)(address . 29296@debbugs.gnu.org)
87fu9fsrxn.fsf@gmail.com
Hi Ludo,

I must admit i don't have a perfect understanding of what is going on in
gexp.scm but your serie LGTM.

When diffing with the initial patch it seems that the entry in
.dir-locals.el is gone but it is a minor point.

About the integration of let-system in "system-disk-image", i'm not sure
how to proceed. let-system is meant to be used in a gexp but the
operating-system is not defined in a gexp.

Do you have any advice on how to turn os declaration into a gexp so that
i can use let-system to parameterize kernel field ?

Thanks,

Mathieu
L
L
Ludovic Courtès wrote on 16 Nov 2017 10:10
(name . Mathieu Othacehe)(address . m.othacehe@gmail.com)(address . 29296@debbugs.gnu.org)
87mv3mk2ql.fsf@gnu.org
Hi Mathieu,

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

Toggle quote (6 lines)
> I must admit i don't have a perfect understanding of what is going on in
> gexp.scm but your serie LGTM.
>
> When diffing with the initial patch it seems that the entry in
> .dir-locals.el is gone but it is a minor point.

Oops.

Toggle quote (7 lines)
> About the integration of let-system in "system-disk-image", i'm not sure
> how to proceed. let-system is meant to be used in a gexp but the
> operating-system is not defined in a gexp.
>
> Do you have any advice on how to turn os declaration into a gexp so that
> i can use let-system to parameterize kernel field ?

The idea is that you can write:

(kernel (let-system system
(if (string-prefix? "arm-" system)
linux-libre-arm
linux-libre)))

and things will just work.

Now I found a couple of issues. First one is addressed with the patch
below. Second one is trickier: (file-append (let-system …) …), as is
used to compute the kernel file name, doesn’t work due to the way the
<file-append> expander works.

I’ll see what I can do.

Thanks,
Ludo’.
Toggle diff (21 lines)
diff --git a/gnu/system.scm b/gnu/system.scm
index 9e05c4b21..a4804cf86 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -876,10 +876,12 @@ listed in OS. The C library expects to find it under
(define (kernel->boot-label kernel)
"Return a label for the bootloader menu entry that boots KERNEL."
- (string-append "GNU with "
- (string-titlecase (package-name kernel)) " "
- (package-version kernel)
- " (beta)"))
+ (if (package? kernel)
+ (string-append "GNU with "
+ (string-titlecase (package-name kernel)) " "
+ (package-version kernel)
+ " (beta)")
+ "GNU GuixSD (beta)"))
(define (store-file-system file-systems)
"Return the file system object among FILE-SYSTEMS that contains the store."
L
L
Ludovic Courtès wrote on 16 May 2020 00:43
Re: bug#41120: uvesafb service is unsupported on aarch64
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
87sgg0stt5.fsf@gnu.org
Hi Mathieu,

Mathieu Othacehe <othacehe@gnu.org> skribis:

Toggle quote (3 lines)
> Here's a rebased version of Ludo's patch. I'm not sure about the merge
> resolution in "lower-object", but otherwise it works fine!

I took another look, and you’re right, it does the job. There were a
couple of issues: returning a self-quoting value as in

(let-system s s)

wouldn’t work, and also caching wasn’t quite right (could be seen by
comparing GUIX_PROFILING="add-data-to-store-cache object-cache" before
and after).

Anyway, it took me much more time than I thought, but it’s here now:

502f609d05 vm: Use 'let-system'.
300a54bb98 utils: 'target-arm32?' & co. take an optional parameter.
644cb40cd8 gexp: Add 'let-system'.
d03001a31a gexp: Compilers can now return lowerable objects.

Let me know how it goes!

Ludo’.
Closed
M
M
Mathieu Othacehe wrote on 18 May 2020 14:16
(name . Ludovic Courtès)(address . ludo@gnu.org)
87o8qlfnff.fsf@gnu.org
Hey Ludo,

Toggle quote (9 lines)
> Anyway, it took me much more time than I thought, but it’s here now:
>
> 502f609d05 vm: Use 'let-system'.
> 300a54bb98 utils: 'target-arm32?' & co. take an optional parameter.
> 644cb40cd8 gexp: Add 'let-system'.
> d03001a31a gexp: Compilers can now return lowerable objects.
>
> Let me know how it goes!

Thanks a lot, it's a great addition. I plan to use it soon to have
kernel/architecture specific services, as I proposed earlier in this
thread.

Mathieu
Closed
D
D
Danny Milosavljevic wrote on 23 May 2020 00:44
Re: [bug#29296] [PATCH 2/2] gexp: Add 'let-system'.
(name . Ludovic Courtès)(address . ludo@gnu.org)
20200523004434.059d1960@scratchpost.org
Hi Ludo,

maybe a little off-topic, but why do I have to use the following patch on
armhf-linux (*not* cross compiling) in order to stop it from pulling in
i686-cross-gcc?

Makes no sense to me at all...

Toggle diff (16 lines)
diff --git a/gnu/packages/mes.scm b/gnu/packages/mes.scm
index 347aef0..524b8e8 100644
--- a/gnu/packages/mes.scm
+++ b/gnu/packages/mes.scm
@@ -120,8 +120,9 @@ extensive examples, including parsers for the Javascript and C99 languages.")
((string-prefix? "x86_64-linux" target-system)
;; Use cross-compiler rather than #:system "i686-linux" to get
;; MesCC 64 bit .go files installed ready for use with Guile.
- `(("i686-linux-binutils" ,(cross-binutils "i686-unknown-linux-gnu"))
- ("i686-linux-gcc" ,(cross-gcc "i686-unknown-linux-gnu"))))
+ `( ;("i686-linux-binutils" ,(cross-binutils "i686-unknown-linux-gnu"))
+ ;("i686-linux-gcc" ,(cross-gcc "i686-unknown-linux-gnu"))
+))
(else
'())))
("graphviz" ,graphviz)
-----BEGIN PGP SIGNATURE-----

iQEzBAEBCgAdFiEEds7GsXJ0tGXALbPZ5xo1VCwwuqUFAl7IVdIACgkQ5xo1VCww
uqXbMwf/dADyXhUuoZzv+Z9Wiqj7hH2lqWmg4usmpUx3ZLAPNti2b24e1KBGO4m6
8UlSB8A9T2wCZ/kBp1Ivl1B4bSzvQppEIc2Qnov+hb0ic6l7XfC42IvNs3EdQzm8
ETj355f7eSdGJyqjgw5Oigc4pPxeV57lKWHNMyCbrD+JUqx2fwxzUM3Xea+BOIjf
fljPvz38a11OIXnkVwNkLKLCfWV3MBl/IwaPfdIa5r2EcuZK41kMxmMmXZsipxEa
fCyWDAlewBl6hBnSF1ZUtMuioa44bLx11Ix+evsZ3hnExdlgVd0NGGP/kw1al9QK
CdGUv2Jx9ERqsaoKt8+ryJSrKZWiLw==
=mAwS
-----END PGP SIGNATURE-----


M
M
Marius Bakke wrote on 23 May 2020 01:01
87blmf8thf.fsf@devup.no
Danny Milosavljevic <dannym@scratchpost.org> writes:

Toggle quote (6 lines)
> Hi Ludo,
>
> maybe a little off-topic, but why do I have to use the following patch on
> armhf-linux (*not* cross compiling) in order to stop it from pulling in
> i686-cross-gcc?

Can you give a little more context? Did this occur after the let-system
patch, or is this when using let-system?

Can you paste the derivation for mes@0.19 in the context this occurs?

Also, please file a new bug report.

Toggle quote (2 lines)
> Makes no sense to me at all...

If only all bugs were obvious, our jobs would be so much easier!

Toggle quote (16 lines)
> diff --git a/gnu/packages/mes.scm b/gnu/packages/mes.scm
> index 347aef0..524b8e8 100644
> --- a/gnu/packages/mes.scm
> +++ b/gnu/packages/mes.scm
> @@ -120,8 +120,9 @@ extensive examples, including parsers for the Javascript and C99 languages.")
> ((string-prefix? "x86_64-linux" target-system)
> ;; Use cross-compiler rather than #:system "i686-linux" to get
> ;; MesCC 64 bit .go files installed ready for use with Guile.
> - `(("i686-linux-binutils" ,(cross-binutils "i686-unknown-linux-gnu"))
> - ("i686-linux-gcc" ,(cross-gcc "i686-unknown-linux-gnu"))))
> + `( ;("i686-linux-binutils" ,(cross-binutils "i686-unknown-linux-gnu"))
> + ;("i686-linux-gcc" ,(cross-gcc "i686-unknown-linux-gnu"))
> +))
> (else
> '())))
> ("graphviz" ,graphviz)
-----BEGIN PGP SIGNATURE-----

iQEzBAEBCgAdFiEEu7At3yzq9qgNHeZDoqBt8qM6VPoFAl7IWbwACgkQoqBt8qM6
VPqZmAf/YsKv3Xx2cklU9UZkQn+QlEuJMm7GEq3hXvkrmIozyFiIYhNLPaFl7TWO
Ed3dClkZDHiFN4VYFjaLa3q726m0ANrBc2uie/Ri7Xg8L5fqWJLdJgOJ0poPcTk0
0Qt0jIyaM7THrzHKt7wZN0xeVAFrI/RT0b9A2uDu9vrjPLNikXDS4LsxBaOu+0CL
3cQHFdjyc2afHM/4HJPPVUG5g2SvtmEq2TeF8tSmlJv0b7IZeeOPF1JRIWwi5Bkv
n6YDA96BlTqbgL33663mcpQHa/1pdbyW/ezVC+DgQmngkEUJFoVWFgvUbknc+O1L
zJ7x9rZAMjlj7XzbBmZYvcrdZEE63Q==
=tSFq
-----END PGP SIGNATURE-----

?
Your comment

This issue is archived.

To comment on this conversation send an email to 29296@debbugs.gnu.org

To respond to this issue using the mumi CLI, first switch to it
mumi current 29296
Then, you may apply the latest patchset in this issue (with sign off)
mumi am -- -s
Or, compose a reply to this issue
mumi compose
Or, send patches to this issue
mumi send-email *.patch