diff options
| -rw-r--r-- | .dir-locals.el | 9 | ||||
| -rw-r--r-- | doc/guix.texi | 40 | ||||
| -rw-r--r-- | guix/gexp.scm | 144 | ||||
| -rw-r--r-- | tests/gexp.scm | 103 |
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") |