aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-08-18 14:53:10 +0200
committerLudovic Courtès <ludo@gnu.org>2014-08-18 15:01:58 +0200
commit667b2508464374a01db3588504b981ec9266a2ea (patch)
tree64c495a3dda285cdfa3e89589864ec58a02c6042
parent68a61e9ffb4d1c8b54db68d61a3669bda50f1bd2 (diff)
downloadguix-667b2508464374a01db3588504b981ec9266a2ea.tar
guix-667b2508464374a01db3588504b981ec9266a2ea.tar.gz
gexp: Add 'ungexp-native' and 'ungexp-native-splicing'.
* guix/gexp.scm (<gexp>)[natives]: New field. (write-gexp): Use both 'gexp-references' and 'gexp-native-references'. (gexp->derivation): Use both 'gexp-inputs' and 'gexp-native-inputs', and append them. (gexp-inputs): Add 'references' parameter and honor it. (gexp-native-inputs): New procedure. (gexp->sexp)[reference->sexp]: Add 'native?' parameter and honor it. Use it, and use 'gexp-native-references'. (gexp)[collect-native-escapes]: New procedure. [escape->ref]: Handle 'ungexp-native' and 'ungexp-native-splicing'. [substitute-ungexp, substitute-ungexp-splicing]: New procedures. [substitute-references]: Use them, and handle 'ungexp-native' and 'ungexp-native-splicing'. Adjust generated 'make-gexp' call to provide both normal references and native references. [read-ungexp]: Support 'ungexp-native' and 'ungexp-native-splicing'. Add reader extension for #+. * tests/gexp.scm (gexp-native-inputs): New procedure. (gexp->sexp*): Add 'target' parameter. ("ungexp + ungexp-native", "input list + ungexp-native", "input list splicing + ungexp-native-splicing", "gexp->derivation, ungexp-native", "gexp->derivation, ungexp + ungexp-native"): New tests. ("sugar"): Add tests for #+ and #+@. * doc/guix.texi (G-Expressions): Document 'ungexp-native' et al.
-rw-r--r--.dir-locals.el9
-rw-r--r--doc/guix.texi40
-rw-r--r--guix/gexp.scm144
-rw-r--r--tests/gexp.scm103
4 files changed, 246 insertions, 50 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
index 69c25cbe8f..ce7033757d 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -40,11 +40,12 @@
(eval . (put 'mlet 'scheme-indent-function 2))
(eval . (put 'run-with-store 'scheme-indent-function 1))
- ;; Recognize '~' and '$', as used for gexps, as quotation symbols. This
- ;; notably allows '(' in Paredit to not insert a space when the preceding
- ;; symbol is one of these.
+ ;; Recognize '~', '+', and '$', as used for gexps, as quotation symbols.
+ ;; This notably allows '(' in Paredit to not insert a space when the
+ ;; preceding symbol is one of these.
(eval . (modify-syntax-entry ?~ "'"))
- (eval . (modify-syntax-entry ?$ "'"))))
+ (eval . (modify-syntax-entry ?$ "'"))
+ (eval . (modify-syntax-entry ?+ "'"))))
(emacs-lisp-mode . ((indent-tabs-mode . nil)))
(texinfo-mode . ((indent-tabs-mode . nil)
(fill-column . 72))))
diff --git a/doc/guix.texi b/doc/guix.texi
index 8381b388cc..09ed39213c 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2160,8 +2160,32 @@ substituted to the reference to the @var{coreutils} package in the
actual build code, and @var{coreutils} is automatically made an input to
the derivation. Likewise, @code{#$output} (equivalent to @code{(ungexp
output)}) is replaced by a string containing the derivation's output
-directory name. The syntactic form to construct gexps is summarized
-below.
+directory name.
+
+@cindex cross compilation
+In a cross-compilation context, it is useful to distinguish between
+references to the @emph{native} build of a package---that can run on the
+host---versus references to cross builds of a package. To that end, the
+@code{#+} plays the same role as @code{#$}, but is a reference to a
+native package build:
+
+@example
+(gexp->derivation "vi"
+ #~(begin
+ (mkdir #$output)
+ (system* (string-append #+coreutils "/bin/ln")
+ "-s"
+ (string-append #$emacs "/bin/emacs")
+ (string-append #$output "/bin/vi")))
+ #:target "mips64el-linux")
+@end example
+
+@noindent
+In the example above, the native build of @var{coreutils} is used, so
+that @command{ln} can actually run on the host; but then the
+cross-compiled build of @var{emacs} is referenced.
+
+The syntactic form to construct gexps is summarized below.
@deffn {Scheme Syntax} #~@var{exp}
@deffnx {Scheme Syntax} (gexp @var{exp})
@@ -2190,6 +2214,13 @@ This is like the form above, but referring explicitly to the
@var{package-or-derivation} produces multiple outputs (@pxref{Packages
with Multiple Outputs}).
+@item #+@var{obj}
+@itemx #+@var{obj}:output
+@itemx (ungexp-native @var{obj})
+@itemx (ungexp-native @var{obj} @var{output})
+Same as @code{ungexp}, but produces a reference to the @emph{native}
+build of @var{obj} when used in a cross compilation context.
+
@item #$output[:@var{output}]
@itemx (ungexp output [@var{output}])
Insert a reference to derivation output @var{output}, or to the main
@@ -2202,6 +2233,11 @@ This only makes sense for gexps passed to @code{gexp->derivation}.
Like the above, but splices the contents of @var{lst} inside the
containing list.
+@item #+@@@var{lst}
+@itemx (ungexp-native-splicing @var{lst})
+Like the above, but refers to native builds of the objects listed in
+@var{lst}.
+
@end table
G-expressions created by @code{gexp} or @code{#~} are run-time objects
diff --git a/guix/gexp.scm b/guix/gexp.scm
index f54221feab..6d1f328aef 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -41,7 +41,9 @@
;;; S-expressions (sexps), with two differences:
;;;
;;; 1. References (un-quotations) to derivations or packages in a gexp are
-;;; replaced by the corresponding output file name;
+;;; replaced by the corresponding output file name; in addition, the
+;;; 'ungexp-native' unquote-like form allows code to explicitly refer to
+;;; the native code of a given package, in case of cross-compilation;
;;;
;;; 2. Gexps embed information about the derivations they refer to.
;;;
@@ -52,9 +54,10 @@
;; "G expressions".
(define-record-type <gexp>
- (make-gexp references proc)
+ (make-gexp references natives proc)
gexp?
(references gexp-references) ; ((DRV-OR-PKG OUTPUT) ...)
+ (natives gexp-native-references) ; ((DRV-OR-PKG OUTPUT) ...)
(proc gexp-proc)) ; procedure
(define (write-gexp gexp port)
@@ -65,7 +68,10 @@
;; doing things like (ungexp-splicing (gexp ())) because GEXP's procedure
;; tries to use 'append' on that, which fails with wrong-type-arg.
(false-if-exception
- (write (apply (gexp-proc gexp) (gexp-references gexp)) port))
+ (write (apply (gexp-proc gexp)
+ (append (gexp-references gexp)
+ (gexp-native-references gexp)))
+ port))
(format port " ~a>"
(number->string (object-address gexp) 16)))
@@ -134,9 +140,13 @@ The other arguments are as for 'derivation'."
(target -> (if (eq? target 'current)
(%current-target-system)
target))
- (inputs (lower-inputs (gexp-inputs exp)
+ (normals (lower-inputs (gexp-inputs exp)
#:system system
#:target target))
+ (natives (lower-inputs (gexp-native-inputs exp)
+ #:system system
+ #:target #f))
+ (inputs -> (append normals natives))
(sexp (gexp->sexp exp
#:system system
#:target target))
@@ -177,8 +187,9 @@ The other arguments are as for 'derivation'."
#:references-graphs references-graphs
#:local-build? local-build?)))
-(define (gexp-inputs exp)
- "Return the input list for EXP."
+(define* (gexp-inputs exp #:optional (references gexp-references))
+ "Return the input list for EXP, using REFERENCES to get its list of
+references."
(define (add-reference-inputs ref result)
(match ref
(((? derivation?) (? string?))
@@ -188,7 +199,7 @@ The other arguments are as for 'derivation'."
(((? origin?) (? string?))
(cons ref result))
((? gexp? exp)
- (append (gexp-inputs exp) result))
+ (append (gexp-inputs exp references) result))
(((? string? file))
(if (direct-store-path? file)
(cons ref result)
@@ -201,7 +212,10 @@ The other arguments are as for 'derivation'."
(fold-right add-reference-inputs
'()
- (gexp-references exp)))
+ (references exp)))
+
+(define gexp-native-inputs
+ (cut gexp-inputs <> gexp-native-references))
(define (gexp-outputs exp)
"Return the outputs referred to by EXP as a list of strings."
@@ -223,7 +237,7 @@ The other arguments are as for 'derivation'."
(target (%current-target-system)))
"Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
and in the current monad setting (system type, etc.)"
- (define (reference->sexp ref)
+ (define* (reference->sexp ref #:optional native?)
(with-monad %store-monad
(match ref
(((? derivation? drv) (? string? output))
@@ -232,7 +246,7 @@ and in the current monad setting (system type, etc.)"
(package-file p
#:output output
#:system system
- #:target target))
+ #:target (if native? #f target)))
(((? origin? o) (? string? output))
(mlet %store-monad ((drv (origin->derivation o)))
(return (derivation->output-path drv output))))
@@ -242,17 +256,22 @@ and in the current monad setting (system type, etc.)"
;; that trick.
(return `((@ (guile) getenv) ,output)))
((? gexp? exp)
- (gexp->sexp exp #:system system #:target target))
+ (gexp->sexp exp
+ #:system system
+ #:target (if native? #f target)))
(((? string? str))
(return (if (direct-store-path? str) str ref)))
((refs ...)
- (sequence %store-monad (map reference->sexp refs)))
+ (sequence %store-monad
+ (map (cut reference->sexp <> native?) refs)))
(x
(return x)))))
(mlet %store-monad
((args (sequence %store-monad
- (map reference->sexp (gexp-references exp)))))
+ (append (map reference->sexp (gexp-references exp))
+ (map (cut reference->sexp <> #t)
+ (gexp-native-references exp))))))
(return (apply (gexp-proc exp) args))))
(define (canonicalize-reference ref)
@@ -309,9 +328,28 @@ package/derivation references."
(_
result))))
+ (define (collect-native-escapes exp)
+ ;; Return all the 'ungexp-native' forms present in EXP.
+ (let loop ((exp exp)
+ (result '()))
+ (syntax-case exp (ungexp-native ungexp-native-splicing)
+ ((ungexp-native _)
+ (cons exp result))
+ ((ungexp-native _ _)
+ (cons exp result))
+ ((ungexp-native-splicing _ ...)
+ (cons exp result))
+ ((exp0 exp ...)
+ (let ((result (loop #'exp0 result)))
+ (fold loop result #'(exp ...))))
+ (_
+ result))))
+
(define (escape->ref exp)
;; Turn 'ungexp' form EXP into a "reference".
- (syntax-case exp (ungexp ungexp-splicing output)
+ (syntax-case exp (ungexp ungexp-splicing
+ ungexp-native ungexp-native-splicing
+ output)
((ungexp output)
#'(output-ref "out"))
((ungexp output name)
@@ -321,30 +359,49 @@ package/derivation references."
((ungexp drv-or-pkg out)
#'(list drv-or-pkg out))
((ungexp-splicing lst)
+ #'lst)
+ ((ungexp-native thing)
+ #'thing)
+ ((ungexp-native drv-or-pkg out)
+ #'(list drv-or-pkg out))
+ ((ungexp-native-splicing lst)
#'lst)))
+ (define (substitute-ungexp exp substs)
+ ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with
+ ;; the corresponding form in SUBSTS.
+ (match (assoc exp substs)
+ ((_ id)
+ id)
+ (_
+ #'(syntax-error "error: no 'ungexp' substitution"
+ #'ref))))
+
+ (define (substitute-ungexp-splicing exp substs)
+ (syntax-case exp ()
+ ((exp rest ...)
+ (match (assoc #'exp substs)
+ ((_ id)
+ (with-syntax ((id id))
+ #`(append id
+ #,(substitute-references #'(rest ...) substs))))
+ (_
+ #'(syntax-error "error: no 'ungexp-splicing' substitution"
+ #'ref))))))
+
(define (substitute-references exp substs)
;; Return a variant of EXP where all the cars of SUBSTS have been
;; replaced by the corresponding cdr.
- (syntax-case exp (ungexp ungexp-splicing)
+ (syntax-case exp (ungexp ungexp-native
+ ungexp-splicing ungexp-native-splicing)
((ungexp _ ...)
- (match (assoc exp substs)
- ((_ id)
- id)
- (_
- #'(syntax-error "error: no 'ungexp' substitution"
- #'ref))))
+ (substitute-ungexp exp substs))
+ ((ungexp-native _ ...)
+ (substitute-ungexp exp substs))
(((ungexp-splicing _ ...) rest ...)
- (syntax-case exp ()
- ((exp rest ...)
- (match (assoc #'exp substs)
- ((_ id)
- (with-syntax ((id id))
- #`(append id
- #,(substitute-references #'(rest ...) substs))))
- (_
- #'(syntax-error "error: no 'ungexp-splicing' substitution"
- #'ref))))))
+ (substitute-ungexp-splicing exp substs))
+ (((ungexp-native-splicing _ ...) rest ...)
+ (substitute-ungexp-splicing exp substs))
((exp0 exp ...)
#`(cons #,(substitute-references #'exp0 substs)
#,(substitute-references #'(exp ...) substs)))
@@ -352,11 +409,15 @@ package/derivation references."
(syntax-case s (ungexp output)
((_ exp)
- (let* ((escapes (delete-duplicates (collect-escapes #'exp)))
+ (let* ((normals (delete-duplicates (collect-escapes #'exp)))
+ (natives (delete-duplicates (collect-native-escapes #'exp)))
+ (escapes (append normals natives))
(formals (generate-temporaries escapes))
(sexp (substitute-references #'exp (zip escapes formals)))
- (refs (map escape->ref escapes)))
+ (refs (map escape->ref normals))
+ (nrefs (map escape->ref natives)))
#`(make-gexp (map canonicalize-reference (list #,@refs))
+ (map canonicalize-reference (list #,@nrefs))
(lambda #,formals
#,sexp)))))))
@@ -409,22 +470,26 @@ its search path."
(write '(ungexp exp) port))))
#:local-build? #t))
-
;;;
;;; Syntactic sugar.
;;;
(eval-when (expand load eval)
- (define (read-ungexp chr port)
- "Read an 'ungexp' or 'ungexp-splicing' form from PORT."
+ (define* (read-ungexp chr port #:optional native?)
+ "Read an 'ungexp' or 'ungexp-splicing' form from PORT. When NATIVE? is
+true, use 'ungexp-native' and 'ungexp-native-splicing' instead."
(define unquote-symbol
(match (peek-char port)
(#\@
(read-char port)
- 'ungexp-splicing)
+ (if native?
+ 'ungexp-native-splicing
+ 'ungexp-splicing))
(_
- 'ungexp)))
+ (if native?
+ 'ungexp-native
+ 'ungexp))))
(match (read port)
((? symbol? symbol)
@@ -445,6 +510,7 @@ its search path."
;; Extend the reader
(read-hash-extend #\~ read-gexp)
- (read-hash-extend #\$ read-ungexp))
+ (read-hash-extend #\$ read-ungexp)
+ (read-hash-extend #\+ (cut read-ungexp <> <> #t)))
;;; gexp.scm ends here
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 9cc7d41547..694bd409bc 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -39,6 +39,7 @@
;; For white-box testing.
(define gexp-inputs (@@ (guix gexp) gexp-inputs))
+(define gexp-native-inputs (@@ (guix gexp) gexp-native-inputs))
(define gexp->sexp (@@ (guix gexp) gexp->sexp))
(define guile-for-build
@@ -47,10 +48,8 @@
;; Make it the default.
(%guile-for-build guile-for-build)
-(define* (gexp->sexp* exp #:optional
- (system (%current-system)) target)
+(define* (gexp->sexp* exp #:optional target)
(run-with-store %store (gexp->sexp exp
- #:system system
#:target target)
#:guile-for-build guile-for-build))
@@ -137,6 +136,29 @@
(e3 `(display ,txt)))
(equal? `(begin ,e0 ,e1 ,e2 ,e3) (gexp->sexp* exp))))))
+(test-assert "ungexp + ungexp-native"
+ (let* ((exp (gexp (list (ungexp-native %bootstrap-guile)
+ (ungexp coreutils)
+ (ungexp-native glibc)
+ (ungexp binutils))))
+ (target "mips64el-linux")
+ (guile (derivation->output-path
+ (package-derivation %store %bootstrap-guile)))
+ (cu (derivation->output-path
+ (package-cross-derivation %store coreutils target)))
+ (libc (derivation->output-path
+ (package-derivation %store glibc)))
+ (bu (derivation->output-path
+ (package-cross-derivation %store binutils target))))
+ (and (lset= equal?
+ `((,%bootstrap-guile "out") (,glibc "out"))
+ (gexp-native-inputs exp))
+ (lset= equal?
+ `((,coreutils "out") (,binutils "out"))
+ (gexp-inputs exp))
+ (equal? `(list ,guile ,cu ,libc ,bu)
+ (gexp->sexp* exp target)))))
+
(test-assert "input list"
(let ((exp (gexp (display
'(ungexp (list %bootstrap-guile coreutils)))))
@@ -150,6 +172,28 @@
(equal? `(display '(,guile ,cu))
(gexp->sexp* exp)))))
+(test-assert "input list + ungexp-native"
+ (let* ((target "mips64el-linux")
+ (exp (gexp (display
+ (cons '(ungexp-native (list %bootstrap-guile coreutils))
+ '(ungexp (list glibc binutils))))))
+ (guile (derivation->output-path
+ (package-derivation %store %bootstrap-guile)))
+ (cu (derivation->output-path
+ (package-derivation %store coreutils)))
+ (xlibc (derivation->output-path
+ (package-cross-derivation %store glibc target)))
+ (xbu (derivation->output-path
+ (package-cross-derivation %store binutils target))))
+ (and (lset= equal?
+ `((,%bootstrap-guile "out") (,coreutils "out"))
+ (gexp-native-inputs exp))
+ (lset= equal?
+ `((,glibc "out") (,binutils "out"))
+ (gexp-inputs exp))
+ (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu)))
+ (gexp->sexp* exp target)))))
+
(test-assert "input list splicing"
(let* ((inputs (list (list glibc "debug") %bootstrap-guile))
(outputs (list (derivation->output-path
@@ -164,6 +208,16 @@
(equal? (gexp->sexp* exp)
`(list ,@(cons 5 outputs))))))
+(test-assert "input list splicing + ungexp-native-splicing"
+ (let* ((inputs (list (list glibc "debug") %bootstrap-guile))
+ (exp (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs))))))
+ (and (lset= equal?
+ `((,glibc "debug") (,%bootstrap-guile "out"))
+ (gexp-native-inputs exp))
+ (null? (gexp-inputs exp))
+ (equal? (gexp->sexp* exp) ;native
+ (gexp->sexp* exp "mips64el-linux")))))
+
(test-assertm "gexp->file"
(mlet* %store-monad ((exp -> (gexp (display (ungexp %bootstrap-guile))))
(guile (package-file %bootstrap-guile))
@@ -240,6 +294,41 @@
(return (and (member (derivation-file-name xcu) refs)
(not (member (derivation-file-name cu) refs))))))
+(test-assertm "gexp->derivation, ungexp-native"
+ (mlet* %store-monad ((target -> "mips64el-linux")
+ (exp -> (gexp (list (ungexp-native coreutils)
+ (ungexp output))))
+ (xdrv (gexp->derivation "foo" exp
+ #:target target))
+ (drv (gexp->derivation "foo" exp)))
+ (return (string=? (derivation-file-name drv)
+ (derivation-file-name xdrv)))))
+
+(test-assertm "gexp->derivation, ungexp + ungexp-native"
+ (mlet* %store-monad ((target -> "mips64el-linux")
+ (exp -> (gexp (list (ungexp-native coreutils)
+ (ungexp glibc)
+ (ungexp output))))
+ (xdrv (gexp->derivation "foo" exp
+ #:target target))
+ (refs ((store-lift references)
+ (derivation-file-name xdrv)))
+ (xglibc (package->cross-derivation glibc target))
+ (cu (package->derivation coreutils)))
+ (return (and (member (derivation-file-name cu) refs)
+ (member (derivation-file-name xglibc) refs)))))
+
+(test-assertm "gexp->derivation, ungexp-native + composed gexps"
+ (mlet* %store-monad ((target -> "mips64el-linux")
+ (exp0 -> (gexp (list 1 2
+ (ungexp coreutils))))
+ (exp -> (gexp (list 0 (ungexp-native exp0))))
+ (xdrv (gexp->derivation "foo" exp
+ #:target target))
+ (drv (gexp->derivation "foo" exp)))
+ (return (string=? (derivation-file-name drv)
+ (derivation-file-name xdrv)))))
+
(define shebang
(string-append "#!" (derivation->output-path guile-for-build)
"/bin/guile --no-auto-compile"))
@@ -285,8 +374,12 @@
(test-equal "sugar"
'(gexp (foo (ungexp bar) (ungexp baz "out")
(ungexp (chbouib 42))
- (ungexp-splicing (list x y z))))
- '#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)))
+ (ungexp-splicing (list x y z))
+ (ungexp-native foo) (ungexp-native foo "out")
+ (ungexp-native (chbouib 42))
+ (ungexp-native-splicing (list x y z))))
+ '#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)
+ #+foo #+foo:out #+(chbouib 42) #+@(list x y z)))
(test-end "gexp")