From 4a6ec23a9780bd75a7e527bd0dfb1943347869bb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 21 Mar 2020 23:08:04 +0100 Subject: download: Delete the output file upon failure. This allows ENOSPC conditions to be properly reported as such rather than as a hash mismatch due to the availability of a truncated file. Fixes . Reported by Maxim Cournoyer . * guix/build/download.scm (url-fetch): In the failure case, delete FILE. --- guix/build/download.scm | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'guix/build') diff --git a/guix/build/download.scm b/guix/build/download.scm index c647d00f6b..46af149b2f 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -693,6 +693,13 @@ otherwise simply ignore them." (() (format (current-error-port) "failed to download ~s from ~s~%" file url) + + ;; Remove FILE in case we made an incomplete download, for example due + ;; to ENOSPC. + (catch 'system-error + (lambda () + (delete-file file)) + (const #f)) #f)))) ;;; download.scm ends here -- cgit v1.2.3 From 9a067fe7ee3978a2f4f0ca0e89965f0fe49f4ce8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 19 Mar 2020 11:14:29 +0100 Subject: syscalls: 'with-file-lock' re-grabs lock when reentering its dynamic extent. * guix/build/syscalls.scm (call-with-file-lock) (call-with-file-lock/no-wait): Initialize PORT in the 'dynamic-wind' "in" handler. This allows us to re-enter a captured continuation and have the lock grabbed anew. --- guix/build/syscalls.scm | 64 +++++++++++++++++++++++++------------------------ 1 file changed, 33 insertions(+), 31 deletions(-) (limited to 'guix/build') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index ae79a9708f..0938ec0ff1 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1104,47 +1104,49 @@ exception if it's already taken." #t) (define (call-with-file-lock file thunk) - (let ((port (catch 'system-error - (lambda () - (lock-file file)) - (lambda args - ;; When using the statically-linked Guile in the initrd, - ;; 'fcntl-flock' returns ENOSYS unconditionally. Ignore - ;; that error since we're typically the only process running - ;; at this point. - (if (= ENOSYS (system-error-errno args)) - #f - (apply throw args)))))) + (let ((port #f)) (dynamic-wind (lambda () - #t) + (set! port + (catch 'system-error + (lambda () + (lock-file file)) + (lambda args + ;; When using the statically-linked Guile in the initrd, + ;; 'fcntl-flock' returns ENOSYS unconditionally. Ignore + ;; that error since we're typically the only process running + ;; at this point. + (if (= ENOSYS (system-error-errno args)) + #f + (apply throw args)))))) thunk (lambda () (when port (unlock-file port)))))) (define (call-with-file-lock/no-wait file thunk handler) - (let ((port (catch #t - (lambda () - (lock-file file #:wait? #f)) - (lambda (key . args) - (match key - ('flock-error - (apply handler args) - ;; No open port to the lock, so return #f. - #f) - ('system-error - ;; When using the statically-linked Guile in the initrd, - ;; 'fcntl-flock' returns ENOSYS unconditionally. Ignore - ;; that error since we're typically the only process running - ;; at this point. - (if (= ENOSYS (system-error-errno (cons key args))) - #f - (apply throw key args))) - (_ (apply throw key args))))))) + (let ((port #f)) (dynamic-wind (lambda () - #t) + (set! port + (catch #t + (lambda () + (lock-file file #:wait? #f)) + (lambda (key . args) + (match key + ('flock-error + (apply handler args) + ;; No open port to the lock, so return #f. + #f) + ('system-error + ;; When using the statically-linked Guile in the initrd, + ;; 'fcntl-flock' returns ENOSYS unconditionally. Ignore + ;; that error since we're typically the only process running + ;; at this point. + (if (= ENOSYS (system-error-errno (cons key args))) + #f + (apply throw key args))) + (_ (apply throw key args))))))) thunk (lambda () (when port -- cgit v1.2.3 From c086c5af1c48f5caf749ff33498d051d5378d361 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 20 Mar 2020 16:13:20 +0100 Subject: build-system: linux-module: Fix cross compilation. * guix/build-system/linux-module.scm (default-kmod, default-gcc): Delete procedures. (system->arch): New procedure. (make-linux-module-builder)[native-inputs]: Move linux... [inputs]: ...to here. (linux-module-build-cross): New procedure. (linux-module-build): Add TARGET. Pass TARGET and ARCH to build side. (lower): Allow cross-compilation. Move "linux" and "linux-module-builder" to host-inputs. Add target-inputs. Call linux-module-build-cross if TARGET is set, linux-module-build otherwise. * guix/build/linux-module-build-system.scm (configure): Add ARCH argument. (linux-module-build): Adjust comment. Signed-off-by: Danny Milosavljevic --- guix/build-system/linux-module.scm | 162 +++++++++++++++++++++++-------- guix/build/linux-module-build-system.scm | 17 ++-- 2 files changed, 132 insertions(+), 47 deletions(-) (limited to 'guix/build') diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm index 1e1a07d0a2..ca104f7c75 100644 --- a/guix/build-system/linux-module.scm +++ b/guix/build-system/linux-module.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Danny Milosavljevic +;;; Copyright © 2020 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -45,27 +46,16 @@ (let ((module (resolve-interface '(gnu packages linux)))) (module-ref module 'linux-libre))) -(define (default-kmod) - "Return the default kmod package." - - ;; Do not use `@' to avoid introducing circular dependencies. +(define (system->arch system) (let ((module (resolve-interface '(gnu packages linux)))) - (module-ref module 'kmod))) - -(define (default-gcc) - "Return the default gcc package." - - ;; Do not use `@' to avoid introducing circular dependencies. - (let ((module (resolve-interface '(gnu packages gcc)))) - (module-ref module 'gcc-7))) + ((module-ref module 'system->linux-architecture) system))) (define (make-linux-module-builder linux) (package (inherit linux) (name (string-append (package-name linux) "-module-builder")) - (native-inputs - `(("linux" ,linux) - ,@(package-native-inputs linux))) + (inputs + `(("linux" ,linux))) (arguments (substitute-keyword-arguments (package-arguments linux) ((#:phases phases) @@ -97,33 +87,43 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:gcc #:kmod #:linux #:inputs #:native-inputs)) - - (and (not target) ;XXX: no cross-compilation - (bag - (name name) - (system system) - (host-inputs `(,@(if source - `(("source" ,source)) - '()) - ,@inputs - ,@(standard-packages))) - (build-inputs `(("linux" ,linux) ; for "Module.symvers". - ("linux-module-builder" - ,(make-linux-module-builder linux)) - ,@native-inputs - ;; TODO: Remove "gmp", "mpfr", "mpc" since they are - ;; only needed to compile the gcc plugins. Maybe - ;; remove "flex", "bison", "elfutils", "perl", - ;; "openssl". That leaves very little ("bc", "gcc", - ;; "kmod"). - ,@(package-native-inputs linux))) - (outputs outputs) - (build linux-module-build) - (arguments (strip-keyword-arguments private-keywords arguments))))) + `(#:source #:target #:gcc #:kmod #:linux #:inputs #:native-inputs + ,@(if target '() '(#:target)))) + + (bag + (name name) + (system system) (target target) + (build-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@native-inputs + ;; TODO: Remove "gmp", "mpfr", "mpc" since they are + ;; only needed to compile the gcc plugins. Maybe + ;; remove "flex", "bison", "elfutils", "perl", + ;; "openssl". That leaves very little ("bc", "gcc", + ;; "kmod"). + ,@(package-native-inputs linux) + ,@(if target + ;; Use the standard cross inputs of + ;; 'gnu-build-system'. + (standard-cross-packages target 'host) + '()) + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (host-inputs `(,@inputs + ("linux" ,linux) + ("linux-module-builder" + ,(make-linux-module-builder linux)))) + (target-inputs (if target + (standard-cross-packages target 'target) + '())) + (outputs outputs) + (build (if target linux-module-build-cross linux-module-build)) + (arguments (strip-keyword-arguments private-keywords arguments)))) (define* (linux-module-build store name inputs #:key + target (search-paths '()) (tests? #t) (phases '(@ (guix build linux-module-build-system) @@ -152,6 +152,8 @@ search-paths) #:phases ,phases #:system ,system + #:target ,target + #:arch ,(system->arch (or target system)) #:tests? ,tests? #:outputs %outputs #:inputs %build-inputs))) @@ -173,6 +175,88 @@ #:guile-for-build guile-for-build #:substitutable? substitutable?)) +(define* (linux-module-build-cross + store name + #:key + target native-drvs target-drvs + (guile #f) + (outputs '("out")) + (search-paths '()) + (native-search-paths '()) + (tests? #f) + (phases '(@ (guix build linux-module-build-system) + %standard-phases)) + (system (%current-system)) + (substitutable? #t) + (imported-modules + %linux-module-build-system-modules) + (modules '((guix build linux-module-build-system) + (guix build utils)))) + (define builder + `(begin + (use-modules ,@modules) + (let () + (define %build-host-inputs + ',(map (match-lambda + ((name (? derivation? drv) sub ...) + `(,name . ,(apply derivation->output-path drv sub))) + ((name path) + `(,name . ,path))) + native-drvs)) + + (define %build-target-inputs + ',(map (match-lambda + ((name (? derivation? drv) sub ...) + `(,name . ,(apply derivation->output-path drv sub))) + ((name (? package? pkg) sub ...) + (let ((drv (package-cross-derivation store pkg + target system))) + `(,name . ,(apply derivation->output-path drv sub)))) + ((name path) + `(,name . ,path))) + target-drvs)) + + (linux-module-build #:name ,name + #:source ,(match (assoc-ref native-drvs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:system ,system + #:target ,target + #:arch ,(system->arch (or target system)) + #:outputs %outputs + #:inputs %build-target-inputs + #:native-inputs %build-host-inputs + #:search-paths + ',(map search-path-specification->sexp + search-paths) + #:native-search-paths + ',(map + search-path-specification->sexp + native-search-paths) + #:phases ,phases + #:tests? ,tests?)))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:system system + #:inputs (append native-drvs target-drvs) + #:outputs outputs + #:modules imported-modules + #:guile-for-build guile-for-build + #:substitutable? substitutable?)) + (define linux-module-build-system (build-system (name 'linux-module) diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm index 8145d5a724..73d6b101f6 100644 --- a/guix/build/linux-module-build-system.scm +++ b/guix/build/linux-module-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Danny Milosavljevic +;;; Copyright © 2020 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,14 +34,13 @@ ;; Code: ;; Copied from make-linux-libre's "configure" phase. -(define* (configure #:key inputs target #:allow-other-keys) +(define* (configure #:key inputs target arch #:allow-other-keys) (setenv "KCONFIG_NOTIMESTAMP" "1") (setenv "KBUILD_BUILD_TIMESTAMP" (getenv "SOURCE_DATE_EPOCH")) - ;(let ((arch ,(system->linux-architecture - ; (or (%current-target-system) - ; (%current-system))))) - ; (setenv "ARCH" arch) - ; (format #t "`ARCH' set to `~a'~%" (getenv "ARCH"))) + + (setenv "ARCH" arch) + (format #t "`ARCH' set to `~a'~%" (getenv "ARCH")) + (when target (setenv "CROSS_COMPILE" (string-append target "-")) (format #t "`CROSS_COMPILE' set to `~a'~%" @@ -85,8 +85,9 @@ (replace 'install install))) (define* (linux-module-build #:key inputs (phases %standard-phases) - #:allow-other-keys #:rest args) - "Build the given package, applying all of PHASES in order, with a Linux kernel in attendance." + #:allow-other-keys #:rest args) + "Build the given package, applying all of PHASES in order, with a Linux +kernel in attendance." (apply gnu:gnu-build #:inputs inputs #:phases phases args)) -- cgit v1.2.3 From afc6b1c0b635e3268795c0f766be408c5e9858e7 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Sun, 22 Mar 2020 10:42:44 -0400 Subject: build: emacs-utils: Add an option to select scoping for batch eval. In Emacs 27, --eval now evaluates using lexical scoping. This change adds an option to select dynamic scoping, by using a workaround proposed in . * guix/build/emacs-utils.scm (emacs-batch-eval): Add a DYNAMIC? keyword argument. Wrap the EXPR with a call to EVAL that makes use of the argument to select the scoping mode. (emacs-generate-autoloads): Use it. --- guix/build/emacs-utils.scm | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) (limited to 'guix/build') diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm index ab64e3714c..5f7ba71244 100644 --- a/guix/build/emacs-utils.scm +++ b/guix/build/emacs-utils.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2018 Mark H Weaver ;;; Copyright © 2014 Alex Kost -;;; Copyright © 2018 Maxim Cournoyer +;;; Copyright © 2018, 2020 Maxim Cournoyer ;;; Copyright © 2019 Leo Prikler ;;; ;;; This file is part of GNU Guix. @@ -21,6 +21,7 @@ (define-module (guix build emacs-utils) #:use-module (guix build utils) + #:use-module (ice-9 format) #:export (%emacs emacs-batch-eval emacs-batch-edit-file @@ -47,10 +48,12 @@ expr (format #f "~s" expr))) -(define (emacs-batch-eval expr) - "Run Emacs in batch mode, and execute the elisp code EXPR." +(define* (emacs-batch-eval expr #:key dynamic?) + "Run Emacs in batch mode, and execute the Elisp code EXPR. If DYNAMIC? is +true, evaluate using dynamic scoping." (invoke (%emacs) "--quick" "--batch" - (string-append "--eval=" (expr->string expr)))) + (format #f "--eval=(eval '~a ~:[t~;nil~])" + (expr->string expr) dynamic?))) (define (emacs-batch-edit-file file expr) "Load FILE in Emacs using batch mode, and execute the elisp code EXPR." @@ -70,7 +73,7 @@ (expr `(let ((backup-inhibited t) (generated-autoload-file ,file)) (update-directory-autoloads ,directory)))) - (emacs-batch-eval expr))) + (emacs-batch-eval expr #:dynamic? #t))) (define* (emacs-byte-compile-directory dir) "Byte compile all files in DIR and its sub-directories." -- cgit v1.2.3