me/guix
Archived
1
0
Fork 0
Code Activity

gexp: Default to current target.

Browse source 
* guix/gexp.scm (lower-object): Set target argument to 'current by default and
look for the current target system at bind time if needed,
(gexp->file): ditto,
(gexp->script): ditto,
(lower-gexp): make sure lowered extensions are not cross-compiled.

* tests/gexp.scm: Add cross-compilation test-cases for gexp->script and
gexp->file with a target passed explicitely and with a default target.
This commit is contained in:
Mathieu Othacehe 2020-03-06 10:06:54 +01:00
parent 5d52d10661
commit 9a2f99f42f
No known key found for this signature in database
GPG key ID: 8354763531769CA6
2 changed files with 103 additions and 38 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

91
guix/gexp.scm
View file

@ -2,7 +2,7 @@
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -218,7 +218,7 @@ procedure to expand it; otherwise return #f."
(define* (lower-object obj (define* (lower-object obj
#:optional (system (%current-system)) #:optional (system (%current-system))
#:key target) #:key (target 'current))
"Return as a value in %STORE-MONAD the derivation or store item "Return as a value in %STORE-MONAD the derivation or store item
corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true. 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 OBJ must be an object that has an associated gexp compiler, such as a
@ -228,7 +228,10 @@ OBJ must be an object that has an associated gexp compiler, such as a
(raise (condition (&gexp-input-error (input obj))))) (raise (condition (&gexp-input-error (input obj)))))
(lower (lower
;; Cache in STORE the result of lowering OBJ. ;; Cache in STORE the result of lowering OBJ.
(mlet %store-monad ((graft? (grafting?))) (mlet %store-monad ((target (if (eq? target 'current)
(current-target-system)
(return target)))
(graft? (grafting?)))
(mcached (let ((lower (lookup-compiler obj))) (mcached (let ((lower (lookup-compiler obj)))
(lower obj system target)) (lower obj system target))
obj obj
@ -779,7 +782,8 @@ derivations--e.g., code evaluated for its side effects."
(extensions -> (gexp-extensions exp)) (extensions -> (gexp-extensions exp))
(exts (mapm %store-monad (exts (mapm %store-monad
(lambda (obj) (lambda (obj)
(lower-object obj system)) (lower-object obj system
#:target #f))
extensions)) extensions))
(modules+compiled (imported+compiled-modules (modules+compiled (imported+compiled-modules
%modules system %modules system
@ -1597,16 +1601,19 @@ are searched for in PATH. Return #f when MODULES and EXTENSIONS are empty."
#:key (guile (default-guile)) #:key (guile (default-guile))
(module-path %load-path) (module-path %load-path)
(system (%current-system)) (system (%current-system))
target) (target 'current))
"Return an executable script NAME that runs EXP using GUILE, with EXP's "Return an executable script NAME that runs EXP using GUILE, with EXP's
imported modules in its search path. Look up EXP's modules in MODULE-PATH." imported modules in its search path. Look up EXP's modules in MODULE-PATH."
(mlet %store-monad ((set-load-path (mlet* %store-monad ((target (if (eq? target 'current)
(load-path-expression (gexp-modules exp) (current-target-system)
module-path (return target)))
#:extensions (set-load-path
(gexp-extensions exp) (load-path-expression (gexp-modules exp)
#:system system module-path
#:target target))) #:extensions
(gexp-extensions exp)
#:system system
#:target target)))
(gexp->derivation name (gexp->derivation name
(gexp (gexp
(call-with-output-file (ungexp output) (call-with-output-file (ungexp output)
@ -1640,7 +1647,7 @@ imported modules in its search path. Look up EXP's modules in MODULE-PATH."
(module-path %load-path) (module-path %load-path)
(splice? #f) (splice? #f)
(system (%current-system)) (system (%current-system))
target) (target 'current))
"Return a derivation that builds a file NAME containing EXP. When SPLICE? "Return a derivation that builds a file NAME containing EXP. When SPLICE?
is true, EXP is considered to be a list of expressions that will be spliced in is true, EXP is considered to be a list of expressions that will be spliced in
the resulting file. the resulting file.
@ -1651,36 +1658,44 @@ Lookup EXP's modules in MODULE-PATH."
(define modules (gexp-modules exp)) (define modules (gexp-modules exp))
(define extensions (gexp-extensions exp)) (define extensions (gexp-extensions exp))
(if (or (not set-load-path?) (mlet* %store-monad
(and (null? modules) (null? extensions))) ((target (if (eq? target 'current)
(gexp->derivation name (current-target-system)
(gexp (return target)))
(call-with-output-file (ungexp output) (no-load-path? -> (or (not set-load-path?)
(lambda (port) (and (null? modules)
(for-each (lambda (exp) (null? extensions))))
(write exp port)) (set-load-path
'(ungexp (if splice? (load-path-expression modules module-path
exp #:extensions extensions
(gexp ((ungexp exp))))))))) #:system system
#:local-build? #t #:target target)))
#:substitutable? #f (if no-load-path?
#:system system (gexp->derivation name
#:target target) (gexp
(mlet %store-monad ((set-load-path (call-with-output-file (ungexp output)
(load-path-expression modules module-path (lambda (port)
#:extensions extensions (for-each
#:system system (lambda (exp)
#:target target))) (write exp port))
'(ungexp (if splice?
exp
(gexp ((ungexp exp)))))))))
#:local-build? #t
#:substitutable? #f
#:system system
#:target target)
(gexp->derivation name (gexp->derivation name
(gexp (gexp
(call-with-output-file (ungexp output) (call-with-output-file (ungexp output)
(lambda (port) (lambda (port)
(write '(ungexp set-load-path) port) (write '(ungexp set-load-path) port)
(for-each (lambda (exp) (for-each
(write exp port)) (lambda (exp)
'(ungexp (if splice? (write exp port))
exp '(ungexp (if splice?
(gexp ((ungexp exp))))))))) exp
(gexp ((ungexp exp)))))))))
#:module-path module-path #:module-path module-path
#:local-build? #t #:local-build? #t
#:substitutable? #f #:substitutable? #f

50
tests/gexp.scm
View file

@ -1331,6 +1331,56 @@
'#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z) '#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)
#+foo #+foo:out #+(chbouib 42) #+@(list x y z))) #+foo #+foo:out #+(chbouib 42) #+@(list x y z)))
(test-assertm "gexp->file, cross-compilation"
(mlet* %store-monad ((target -> "aarch64-linux-gnu")
(exp -> (gexp (list (ungexp coreutils))))
(xdrv (gexp->file "foo" exp #:target target))
(refs (references*
(derivation-file-name xdrv)))
(xcu (package->cross-derivation coreutils
target))
(cu (package->derivation coreutils)))
(return (and (member (derivation-file-name xcu) refs)
(not (member (derivation-file-name cu) refs))))))
(test-assertm "gexp->file, cross-compilation with default target"
(mlet* %store-monad ((target -> "aarch64-linux-gnu")
(_ (set-current-target target))
(exp -> (gexp (list (ungexp coreutils))))
(xdrv (gexp->file "foo" exp))
(refs (references*
(derivation-file-name xdrv)))
(xcu (package->cross-derivation coreutils
target))
(cu (package->derivation coreutils)))
(return (and (member (derivation-file-name xcu) refs)
(not (member (derivation-file-name cu) refs))))))
(test-assertm "gexp->script, cross-compilation"
(mlet* %store-monad ((target -> "aarch64-linux-gnu")
(exp -> (gexp (list (ungexp coreutils))))
(xdrv (gexp->script "foo" exp #:target target))
(refs (references*
(derivation-file-name xdrv)))
(xcu (package->cross-derivation coreutils
target))
(cu (package->derivation coreutils)))
(return (and (member (derivation-file-name xcu) refs)
(not (member (derivation-file-name cu) refs))))))
(test-assertm "gexp->script, cross-compilation with default target"
(mlet* %store-monad ((target -> "aarch64-linux-gnu")
(_ (set-current-target target))
(exp -> (gexp (list (ungexp coreutils))))
(xdrv (gexp->script "foo" exp))
(refs (references*
(derivation-file-name xdrv)))
(xcu (package->cross-derivation coreutils
target))
(cu (package->derivation coreutils)))
(return (and (member (derivation-file-name xcu) refs)
(not (member (derivation-file-name cu) refs))))))
(test-end "gexp") (test-end "gexp")
;; Local Variables: ;; Local Variables: