diff options
author | Marius Bakke <mbakke@fastmail.com> | 2019-10-08 19:24:34 +0200 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2019-10-08 19:24:34 +0200 |
commit | d1f3b333e6176a7879ab3742bbebb2a99f61a528 (patch) | |
tree | 8bd82ce68bd2534a48bf13c7256997f82dd1b3f4 /guix/build | |
parent | e01d384efcdaf564bbb221e43b81e087c8e2af06 (diff) | |
parent | 861907f01efb1cae7f260e8cb7b991d5034a486a (diff) |
Merge branch 'master' into staging
Diffstat (limited to 'guix/build')
-rw-r--r-- | guix/build/cargo-build-system.scm | 38 | ||||
-rw-r--r-- | guix/build/compile.scm | 9 | ||||
-rw-r--r-- | guix/build/gnu-build-system.scm | 130 | ||||
-rw-r--r-- | guix/build/go-build-system.scm | 2 | ||||
-rw-r--r-- | guix/build/julia-build-system.scm | 135 | ||||
-rw-r--r-- | guix/build/lisp-utils.scm | 14 | ||||
-rw-r--r-- | guix/build/make-bootstrap.scm | 72 | ||||
-rw-r--r-- | guix/build/meson-build-system.scm | 1 | ||||
-rw-r--r-- | guix/build/python-build-system.scm | 33 | ||||
-rw-r--r-- | guix/build/ruby-build-system.scm | 2 | ||||
-rw-r--r-- | guix/build/syscalls.scm | 44 | ||||
-rw-r--r-- | guix/build/utils.scm | 230 |
12 files changed, 583 insertions, 127 deletions
diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 8aa9390457..8a8d74ee1b 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -66,10 +66,10 @@ Cargo.toml file present at its root." ;; archive, but not nested anywhere else). We do this by cutting up ;; each output line and only looking at the second component. We then ;; check if it matches Cargo.toml exactly and short circuit if it does. - (zero? (apply system* (list "sh" "-c" - (string-append "tar -tf " path - " | cut -d/ -f2" - " | grep -q '^Cargo.toml$'")))))) + (apply invoke (list "sh" "-c" + (string-append "tar -tf " path + " | cut -d/ -f2" + " | grep -q '^Cargo.toml$'"))))) (define* (configure #:key inputs (vendor-dir "guix-vendor") @@ -84,7 +84,7 @@ Cargo.toml file present at its root." (for-each (match-lambda ((name . path) - (let* ((basepath (basename path)) + (let* ((basepath (strip-store-file-name path)) (crate-dir (string-append vendor-dir "/" basepath))) (and (crate-src? path) ;; Gracefully handle duplicate inputs @@ -119,22 +119,12 @@ directory = '" port) ;; upgrading the compiler for example. (setenv "RUSTFLAGS" "--cap-lints allow") (setenv "CC" (string-append (assoc-ref inputs "gcc") "/bin/gcc")) - #t) -;; The Cargo.lock file tells the build system which crates are required for -;; building and hardcodes their version and checksum. In order to build with -;; the inputs we provide, we need to recreate the file with our inputs. -(define* (update-cargo-lock #:key - (vendor-dir "guix-vendor") - #:allow-other-keys) - "Regenerate the Cargo.lock file with the current build inputs." + ;; We don't use the Cargo.lock file to determine the package versions we use + ;; during building, and in any case if one is not present it is created + ;; during the 'build phase by cargo. (when (file-exists? "Cargo.lock") - (begin - ;; Unfortunately we can't generate a Cargo.lock file until the checksums - ;; are generated, so we have an extra round of generate-all-checksums here. - (generate-all-checksums vendor-dir) - (delete-file "Cargo.lock") - (invoke "cargo" "generate-lockfile"))) + (delete-file "Cargo.lock")) #t) ;; After the 'patch-generated-file-shebangs phase any vendored crates who have @@ -152,7 +142,7 @@ directory = '" port) #:allow-other-keys) "Build a given Cargo package." (or skip-build? - (zero? (apply system* `("cargo" "build" ,@cargo-build-flags))))) + (apply invoke `("cargo" "build" ,@cargo-build-flags)))) (define* (check #:key tests? @@ -160,12 +150,9 @@ directory = '" port) #:allow-other-keys) "Run tests for a given Cargo package." (if tests? - (zero? (apply system* `("cargo" "test" ,@cargo-test-flags))) + (apply invoke `("cargo" "test" ,@cargo-test-flags)) #t)) -(define (touch file-name) - (call-with-output-file file-name (const #t))) - (define* (install #:key inputs outputs skip-build? #:allow-other-keys) "Install a given Cargo package." (let* ((out (assoc-ref outputs "out"))) @@ -179,7 +166,7 @@ directory = '" port) ;; otherwise cargo will raise an error. (or skip-build? (not (has-executable-target?)) - (zero? (system* "cargo" "install" "--path" "." "--root" out))))) + (invoke "cargo" "install" "--path" "." "--root" out)))) (define %standard-phases (modify-phases gnu:%standard-phases @@ -188,7 +175,6 @@ directory = '" port) (replace 'build build) (replace 'check check) (replace 'install install) - (add-after 'configure 'update-cargo-lock update-cargo-lock) (add-after 'patch-generated-file-shebangs 'patch-cargo-checksums patch-cargo-checksums))) (define* (cargo-build #:key inputs (phases %standard-phases) diff --git a/guix/build/compile.scm b/guix/build/compile.scm index c127456fd0..06ed57c9d7 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -169,11 +169,12 @@ BUILD-DIRECTORY, using up to WORKERS parallel workers. The resulting object files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"." (define progress-lock (make-mutex)) (define total (length files)) - (define completed 0) + (define progress 0) (define (build file) (with-mutex progress-lock - (report-compilation file total completed)) + (report-compilation file total progress) + (set! progress (+ 1 progress))) ;; Exit as soon as something goes wrong. (exit-on-exception @@ -185,9 +186,7 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"." #:output-file (string-append build-directory "/" (scm->go relative)) #:opts (append warning-options - (optimization-options relative))))))) - (with-mutex progress-lock - (set! completed (+ 1 completed)))) + (optimization-options relative)))))))) (with-augmented-search-path %load-path source-directory (with-augmented-search-path %load-compiled-path build-directory diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index e5f3197b0a..4df0bb4904 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -25,6 +25,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 format) + #:use-module (ice-9 ftw) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-34) @@ -58,19 +59,14 @@ See https://reproducible-builds.org/specs/source-date-epoch/." (setenv "SOURCE_DATE_EPOCH" "1") #t) -(define (first-subdirectory dir) - "Return the path of the first sub-directory of DIR." - (file-system-fold (lambda (path stat result) - (string=? path dir)) - (lambda (path stat result) result) ; leaf - (lambda (path stat result) result) ; down - (lambda (path stat result) result) ; up - (lambda (path stat result) ; skip - (or result path)) - (lambda (path stat errno result) ; error - (error "first-subdirectory" (strerror errno))) - #f - dir)) +(define (first-subdirectory directory) + "Return the file name of the first sub-directory of DIRECTORY." + (match (scandir directory + (lambda (file) + (and (not (member file '("." ".."))) + (file-is-directory? (string-append directory "/" + file))))) + ((first . _) first))) (define* (set-paths #:key target inputs native-inputs (search-paths '()) (native-search-paths '()) @@ -735,23 +731,64 @@ which cannot be found~%" (define* (install-license-files #:key outputs (license-file-regexp %license-file-regexp) + out-of-source? #:allow-other-keys) "Install license files matching LICENSE-FILE-REGEXP to 'share/doc'." + (define (find-source-directory package) + ;; For an out-of-source build, guess the source directory location + ;; relative to the current directory. Return #f on failure. + (match (scandir ".." + (lambda (file) + (and (not (member file '("." ".." "build"))) + (file-is-directory? + (string-append "../" file))))) + (() ;hmm, no source + #f) + ((source) ;only one other file + (string-append "../" source)) + ((directories ...) ;pick the most likely one + ;; This happens for example with libstdc++, which lives within the GCC + ;; source tree. + (any (lambda (directory) + (and (string-prefix? package directory) + (string-append "../" directory))) + directories)))) + + (define (copy-to-directories directories sub-directory) + (lambda (file) + (for-each (if (file-is-directory? file) + (cut copy-recursively file <>) + (cut install-file file <>)) + (map (cut string-append <> "/" sub-directory) + directories)))) + (let* ((regexp (make-regexp license-file-regexp)) (out (or (assoc-ref outputs "out") (match outputs (((_ . output) _ ...) output)))) (package (strip-store-file-name out)) - (directory (string-append out "/share/doc/" package)) - (files (scandir "." (lambda (file) - (regexp-exec regexp file))))) - (format #t "installing ~a license files~%" (length files)) - (for-each (lambda (file) - (if (file-is-directory? file) - (copy-recursively file directory) - (install-file file directory))) - files) + (outputs (match outputs + (((_ . outputs) ...) + outputs))) + (source (if out-of-source? + (find-source-directory + (package-name->name+version package)) + ".")) + (files (and source + (scandir source + (lambda (file) + (regexp-exec regexp file)))))) + (if files + (begin + (format #t "installing ~a license files from '~a'~%" + (length files) source) + (for-each (copy-to-directories outputs + (string-append "share/doc/" + package)) + (map (cut string-append source "/" <>) files))) + (format (current-error-port) + "failed to find license files~%")) #t)) (define %standard-phases @@ -784,34 +821,37 @@ in order. Return #t if all the PHASES succeeded, #f otherwise." (+ (time-second diff) (/ (time-nanosecond diff) 1e9)))) - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line) ;; Encoding/decoding errors shouldn't be silent. (fluid-set! %default-port-conversion-strategy 'error) - ;; The trick is to #:allow-other-keys everywhere, so that each procedure in - ;; PHASES can pick the keyword arguments it's interested in. - (every (match-lambda - ((name . proc) - (let ((start (current-time time-monotonic))) - (format #t "starting phase `~a'~%" name) - (let ((result (apply proc args)) - (end (current-time time-monotonic))) - (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%" - name result - (elapsed-time end start)) - - ;; Issue a warning unless the result is #t. - (unless (eqv? result #t) - (format (current-error-port) "\ + (guard (c ((invoke-error? c) + (report-invoke-error c) + (exit 1))) + ;; The trick is to #:allow-other-keys everywhere, so that each procedure in + ;; PHASES can pick the keyword arguments it's interested in. + (every (match-lambda + ((name . proc) + (let ((start (current-time time-monotonic))) + (format #t "starting phase `~a'~%" name) + (let ((result (apply proc args)) + (end (current-time time-monotonic))) + (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%" + name result + (elapsed-time end start)) + + ;; Issue a warning unless the result is #t. + (unless (eqv? result #t) + (format (current-error-port) "\ ## WARNING: phase `~a' returned `~s'. Return values other than #t ## are deprecated. Please migrate this package so that its phase ## procedures report errors by raising an exception, and otherwise ## always return #t.~%" - name result)) + name result)) - ;; Dump the environment variables as a shell script, for handy debugging. - (system "export > $NIX_BUILD_TOP/environment-variables") - result)))) - phases)) + ;; Dump the environment variables as a shell script, for handy debugging. + (system "export > $NIX_BUILD_TOP/environment-variables") + result)))) + phases))) diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index 3dac43c18a..4bc0156a88 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -237,7 +237,7 @@ unpacking." "Install the source code of IMPORT-PATH to the primary output directory. Compiled executable files (Go \"commands\") should have already been installed to the store based on $GOBIN in the build phase. -XXX We can't make us of compiled libraries (Go \"packages\")." +XXX We can't make use of compiled libraries (Go \"packages\")." (when install-source? (if (string-null? import-path) ((display "WARNING: The Go import path is unset.\n"))) diff --git a/guix/build/julia-build-system.scm b/guix/build/julia-build-system.scm new file mode 100644 index 0000000000..ff6fcf5fe3 --- /dev/null +++ b/guix/build/julia-build-system.scm @@ -0,0 +1,135 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Nicolò Balzarotti <nicolo@nixo.xyz> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + + +(define-module (guix build julia-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:export (%standard-phases + julia-create-package-toml + julia-build)) + +;; Commentary: +;; +;; Builder-side code of the standard build procedure for Julia packages. +;; +;; Code: + +(define (invoke-julia code) + (invoke "julia" "-e" code)) + +;; subpath where we store the package content +(define %package-path "/share/julia/packages/") + +(define (generate-load-path inputs outputs) + (string-append + (string-join (map (match-lambda + ((_ . path) + (string-append path %package-path))) + ;; Restrict to inputs beginning with "julia-". + (filter (match-lambda + ((name . _) + (string-prefix? "julia-" name))) + inputs)) + ":") + (string-append ":" (assoc-ref outputs "out") %package-path) + ;; stdlib is always required to find Julia's standard libraries. + ;; usually there are other two paths in this variable: + ;; "@" and "@v#.#" + ":@stdlib")) + +(define* (install #:key source inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (package-dir (string-append out %package-path + (string-append + (strip-store-file-name source))))) + (setenv "JULIA_LOAD_PATH" (generate-load-path inputs outputs)) + (mkdir-p package-dir) + (copy-recursively source package-dir)) + #t) + +;; TODO: Precompilation is working, but I don't know how to tell +;; julia to use use it. If (on rantime) we set HOME to +;; store path, julia tries to write files there (failing) +(define* (precompile #:key source inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (builddir (string-append out "/share/julia/")) + (package (strip-store-file-name source))) + (mkdir-p builddir) + (setenv "JULIA_DEPOT_PATH" builddir) + (setenv "JULIA_LOAD_PATH" (generate-load-path inputs outputs)) + ;; Actual precompilation + (invoke-julia (string-append "using " package))) + #t) + +(define* (check #:key source inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (package (strip-store-file-name source)) + (builddir (string-append out "/share/julia/"))) + (setenv "JULIA_DEPOT_PATH" builddir) + (setenv "JULIA_LOAD_PATH" (generate-load-path inputs outputs)) + (invoke-julia (string-append "using Pkg;Pkg.test(\"" package "\")"))) + #t) + +(define (julia-create-package-toml outputs source + name uuid version + deps) + "Some packages are not using the new Package.toml dependency specifications. +Write this file manually, so that Julia can find its dependencies." + (let ((f (open-file + (string-append + (assoc-ref outputs "out") + %package-path + (string-append + name "/Project.toml")) + "w"))) + (display (string-append + " +name = \"" name "\" +uuid = \"" uuid "\" +version = \"" version "\" +") f) + (when (not (null? deps)) + (display "[deps]\n" f) + (for-each (lambda dep + (display (string-append (car (car dep)) " = \"" (cdr (car dep)) "\"\n") + f)) + deps)) + (close-port f)) + #t) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (delete 'check) ; tests must be run after installation + (replace 'install install) + (add-after 'install 'precompile precompile) + ;; (add-after 'install 'check check) + ;; TODO: In the future we could add a "system-image-generation" phase + ;; where we use PackageCompiler.jl to speed up package loading times + (delete 'configure) + (delete 'bootstrap) + (delete 'patch-usr-bin-file) + (delete 'build))) + +(define* (julia-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given Julia package, applying all of PHASES in order." + (apply gnu:gnu-build + #:inputs inputs #:phases phases + args)) diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm index 97bc6197a3..c7a589c902 100644 --- a/guix/build/lisp-utils.scm +++ b/guix/build/lisp-utils.scm @@ -220,12 +220,19 @@ Also load TEST-ASD-FILE if necessary." "Return a lisp keyword for the concatenation of STRINGS." (string->symbol (apply string-append ":" strings))) -(define (generate-executable-for-system type system) +(define* (generate-executable-for-system type system #:key compress?) "Use LISP to generate an executable, whose TYPE can be 'asdf:image-op or 'asdf:program-op. The latter will always be standalone. Depends on having created a \"SYSTEM-exec\" system which contains the entry program." (lisp-eval-program `((require :asdf) + ;; Only SBCL supports compression as of 2019-09-02. + ,(if (and compress? (string=? (%lisp-type) "sbcl")) + '(defmethod asdf:perform ((o asdf:image-op) (c asdf:system)) + (uiop:dump-image (asdf:output-file o c) + :executable t + :compression t)) + '()) (asdf:operate ',type ,(string-append system "-exec"))))) (define (generate-executable-wrapper-system system dependencies) @@ -339,6 +346,7 @@ which are not nested." (dependency-prefixes (list (library-output outputs))) (dependencies (list (basename program))) entry-program + compress? #:allow-other-keys) "Generate an executable program containing all DEPENDENCIES, and which will execute ENTRY-PROGRAM. The result is placed in PROGRAM. When executed, it @@ -350,6 +358,7 @@ retained." #:dependencies dependencies #:dependency-prefixes dependency-prefixes #:entry-program entry-program + #:compress? compress? #:type 'asdf:program-op) (let* ((name (basename program)) (bin-directory (dirname program))) @@ -382,6 +391,7 @@ DEPENDENCY-PREFIXES to ensure references to those libraries are retained." dependency-prefixes entry-program type + compress? #:allow-other-keys) "Generate an executable by using asdf operation TYPE, containing whithin the image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an @@ -405,7 +415,7 @@ references to those libraries are retained." `(((,bin-directory :**/ :*.*.*) (,bin-directory :**/ :*.*.*))))))) - (generate-executable-for-system type name) + (generate-executable-for-system type name #:compress? compress?) (let* ((after-store-prefix-index (string-index out-file #\/ diff --git a/guix/build/make-bootstrap.scm b/guix/build/make-bootstrap.scm index 48799f7e90..e5ef1d6d2b 100644 --- a/guix/build/make-bootstrap.scm +++ b/guix/build/make-bootstrap.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2017 Manolis Fragkiskos Ragkousis <manolis837@gmail.com> ;;; Copyright © 2015, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,7 +24,8 @@ #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (guix build utils) - #:export (make-stripped-libc)) + #:export (copy-linux-headers + make-stripped-libc)) ;; Commentary: ;; @@ -31,6 +33,53 @@ ;; ;; Code: +(define (copy-linux-headers output kernel-headers) + "Copy to OUTPUT the subset of KERNEL-HEADERS that is needed when producing a +bootstrap libc." + + (let* ((incdir (string-append output "/include"))) + (mkdir-p incdir) + + ;; Copy some of the Linux-Libre headers that glibc headers + ;; refer to. + (mkdir (string-append incdir "/linux")) + (for-each (lambda (file) + (install-file (pk 'src (string-append kernel-headers "/include/linux/" file)) + (pk 'dest (string-append incdir "/linux")))) + '( + "a.out.h" ; for 2.2.5 + "atalk.h" ; for 2.2.5 + "errno.h" + "falloc.h" + "if_addr.h" ; for 2.16.0 + "if_ether.h" ; for 2.2.5 + "if_link.h" ; for 2.16.0 + "ioctl.h" + "kernel.h" + "limits.h" + "neighbour.h" ; for 2.16.0 + "netlink.h" ; for 2.16.0 + "param.h" + "prctl.h" ; for 2.16.0 + "posix_types.h" + "rtnetlink.h" ; for 2.16.0 + "socket.h" + "stddef.h" + "swab.h" ; for 2.2.5 + "sysctl.h" + "sysinfo.h" ; for 2.2.5 + "types.h" + "version.h" ; for 2.2.5 + )) + + (copy-recursively (string-append kernel-headers "/include/asm") + (string-append incdir "/asm")) + (copy-recursively (string-append kernel-headers "/include/asm-generic") + (string-append incdir "/asm-generic")) + (copy-recursively (string-append kernel-headers "/include/linux/byteorder") + (string-append incdir "/linux/byteorder")) + #t)) + (define (make-stripped-libc output libc kernel-headers) "Copy to OUTPUT the subset of LIBC and KERNEL-HEADERS that is needed when producing a bootstrap libc." @@ -43,25 +92,10 @@ when producing a bootstrap libc." (string-append incdir "/mach")) #t)) - (define (copy-linux-headers output kernel-headers) + (define (copy-libc+linux-headers output kernel-headers) (let* ((incdir (string-append output "/include"))) (copy-recursively (string-append libc "/include") incdir) - - ;; Copy some of the Linux-Libre headers that glibc headers - ;; refer to. - (mkdir (string-append incdir "/linux")) - (for-each (lambda (file) - (install-file (string-append kernel-headers "/include/linux/" file) - (string-append incdir "/linux"))) - '("limits.h" "errno.h" "socket.h" "kernel.h" - "sysctl.h" "param.h" "ioctl.h" "types.h" - "posix_types.h" "stddef.h" "falloc.h")) - - (copy-recursively (string-append kernel-headers "/include/asm") - (string-append incdir "/asm")) - (copy-recursively (string-append kernel-headers "/include/asm-generic") - (string-append incdir "/asm-generic")) - #t)) + (copy-linux-headers output kernel-headers))) (define %libc-object-files-rx "^(crt.*|ld.*|lib(c|m|dl|rt|pthread|nsl|\ util).*\\.so(\\..*)?|lib(machuser|hurduser).so.*|(libc(rt|)|libpthread)\ @@ -80,6 +114,6 @@ _nonshared\\.a)$") (if (directory-exists? (string-append kernel-headers "/include/mach")) (copy-mach-headers output kernel-headers) - (copy-linux-headers output kernel-headers))) + (copy-libc+linux-headers output kernel-headers))) diff --git a/guix/build/meson-build-system.scm b/guix/build/meson-build-system.scm index d0975fcab0..8043a84abb 100644 --- a/guix/build/meson-build-system.scm +++ b/guix/build/meson-build-system.scm @@ -108,6 +108,7 @@ for example libraries only needed for the tests." ;; from the gnu-build-system. If the glib-or-gtk? key is #f (the default) ;; then the extra phases will be removed again in (guix build-system meson). (modify-phases glib-or-gtk:%standard-phases + (delete 'bootstrap) (replace 'configure configure) (replace 'build build) (replace 'check check) diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index 5bb0ba49d5..09bd8465c8 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -1,10 +1,11 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2015, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,6 +32,7 @@ #:export (%standard-phases add-installed-pythonpath site-packages + python-version python-build)) ;; Commentary: @@ -146,7 +148,7 @@ (format #t "test suite not run~%")) #t) -(define (get-python-version python) +(define (python-version python) (let* ((version (last (string-split python #\-))) (components (string-split version #\.)) (major+minor (take components 2))) @@ -157,7 +159,7 @@ (let* ((out (assoc-ref outputs "out")) (python (assoc-ref inputs "python"))) (string-append out "/lib/python" - (get-python-version python) + (python-version python) "/site-packages/"))) (define (add-installed-pythonpath inputs outputs) @@ -186,11 +188,9 @@ when running checks after installing the package." (define* (wrap #:key inputs outputs #:allow-other-keys) (define (list-of-files dir) - (map (cut string-append dir "/" <>) - (or (scandir dir (lambda (f) - (let ((s (stat (string-append dir "/" f)))) - (eq? 'regular (stat:type s))))) - '()))) + (find-files dir (lambda (file stat) + (and (eq? 'regular (stat:type stat)) + (not (wrapper? file)))))) (define bindirs (append-map (match-lambda @@ -203,7 +203,7 @@ when running checks after installing the package." (python (assoc-ref inputs "python")) (var `("PYTHONPATH" prefix ,(cons (string-append out "/lib/python" - (get-python-version python) + (python-version python) "/site-packages") (search-path-as-string->list (or (getenv "PYTHONPATH") "")))))) @@ -223,7 +223,7 @@ installed with setuptools." (let* ((out (assoc-ref outputs "out")) (python (assoc-ref inputs "python")) (site-packages (string-append out "/lib/python" - (get-python-version python) + (python-version python) "/site-packages")) (easy-install-pth (string-append site-packages "/easy-install.pth")) (new-pth (string-append site-packages "/" name ".pth"))) @@ -251,16 +251,21 @@ installed with setuptools." #t) (define %standard-phases - ;; 'configure' phase is not needed. + ;; The build phase only builds C extensions and copies the Python sources, + ;; while the install phase byte-compiles and copies them to the prefix + ;; directory. The tests are run after the install phase because otherwise + ;; the cached .pyc generated during the tests execution seem to interfere + ;; with the byte compilation of the install phase. (modify-phases gnu:%standard-phases (add-after 'unpack 'ensure-no-mtimes-pre-1980 ensure-no-mtimes-pre-1980) (add-after 'ensure-no-mtimes-pre-1980 'enable-bytecode-determinism enable-bytecode-determinism) (delete 'bootstrap) - (delete 'configure) - (replace 'install install) - (replace 'check check) + (delete 'configure) ;not needed (replace 'build build) + (delete 'check) ;moved after the install phase + (replace 'install install) + (add-after 'install 'check check) (add-after 'install 'wrap wrap) (add-before 'strip 'rename-pth-file rename-pth-file))) diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index 63c94765f7..c957a61115 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -128,7 +128,7 @@ is #f." (define* (install #:key inputs outputs (gem-flags '()) #:allow-other-keys) "Install the gem archive SOURCE to the output store item. Additional -GEM-FLAGS are passed to the 'gem' invokation, if present." +GEM-FLAGS are passed to the 'gem' invocation, if present." (let* ((ruby-version (match:substring (string-match "ruby-(.*)\\.[0-9]$" (assoc-ref inputs "ruby")) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 3c84d3893f..bbf2531c79 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -68,6 +68,7 @@ statfs free-disk-space device-in-use? + add-to-entropy-count processes mkdtemp! @@ -396,17 +397,11 @@ the returned procedure is called." ((_ (proc args ...) body ...) (define-as-needed proc (lambda* (args ...) body ...))) ((_ variable value) - (begin - (when (module-defined? the-scm-module 'variable) - (re-export variable)) - - (define variable - (if (module-defined? the-scm-module 'variable) - (module-ref the-scm-module 'variable) - value)) - - (unless (module-defined? the-scm-module 'variable) - (export variable)))))) + (if (module-defined? the-scm-module 'variable) + (module-re-export! (current-module) '(variable)) + (begin + (module-define! (current-module) 'variable value) + (module-export! (current-module) '(variable))))))) ;;; @@ -714,6 +709,33 @@ backend device." ;;; +;;; Random. +;;; + +;; From <uapi/linux/random.h>. +(define RNDADDTOENTCNT #x40045201) + +(define (add-to-entropy-count port-or-fd n) + "Add N to the kernel's entropy count (the value that can be read from +/proc/sys/kernel/random/entropy_avail). PORT-OR-FD must correspond to +/dev/urandom or /dev/random. Raise to 'system-error with EPERM when the +caller lacks root privileges." + (let ((fd (if (port? port-or-fd) + (fileno port-or-fd) + port-or-fd)) + (box (make-bytevector (sizeof int)))) + (bytevector-sint-set! box 0 n (native-endianness) + (sizeof int)) + (let-values (((ret err) + (%ioctl fd RNDADDTOENTCNT + (bytevector->pointer box)))) + (unless (zero? err) + (throw 'system-error "add-to-entropy-count" "~A" + (list (strerror err)) + (list err)))))) + + +;;; ;;; Containers. ;;; diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 5fe3286843..b8be73ead4 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -1,8 +1,10 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -87,7 +89,13 @@ patch-/usr/bin/file fold-port-matches remove-store-references + wrapper? wrap-program + wrap-script + + wrap-error? + wrap-error-program + wrap-error-type invoke invoke-error? @@ -96,10 +104,33 @@ invoke-error-exit-status invoke-error-term-signal invoke-error-stop-signal + report-invoke-error + + invoke/quiet locale-category->string)) + +;;; +;;; Guile 2.0 compatibility later. +;;; +;; The bootstrap Guile is Guile 2.0, so provide a compatibility layer. +(cond-expand + ((and guile-2 (not guile-2.2)) + (define (setvbuf port mode . rest) + (apply (@ (guile) setvbuf) port + (match mode + ('line _IOLBF) + ('block _IOFBF) + ('none _IONBF) + (_ mode)) ;an _IO* integer + rest)) + + (module-replace! (current-module) '(setvbuf))) + (else #f)) + + ;;; ;;; Directories. ;;; @@ -600,6 +631,11 @@ Where every <*-phase-name> is an expression evaluating to a symbol, and ((_ phases (add-after old-phase-name new-phase-name new-phase)) (alist-cons-after old-phase-name new-phase-name new-phase phases)))) + +;;; +;;; Program invocation. +;;; + (define-condition-type &invoke-error &error invoke-error? (program invoke-error-program) @@ -621,6 +657,68 @@ if the exit code is non-zero; otherwise return #t." (stop-signal (status:stop-sig code)))))) #t)) +(define* (report-invoke-error c #:optional (port (current-error-port))) + "Report to PORT about C, an '&invoke-error' condition, in a human-friendly +way." + (format port "command~{ ~s~} failed with ~:[signal~;status~] ~a~%" + (cons (invoke-error-program c) + (invoke-error-arguments c)) + (invoke-error-exit-status c) + (or (invoke-error-exit-status c) + (invoke-error-term-signal c) + (invoke-error-stop-signal c)))) + +(define (open-pipe-with-stderr program . args) + "Run PROGRAM with ARGS in an input pipe, but, unlike 'open-pipe*', redirect +both its standard output and standard error to the pipe. Return two value: +the pipe to read PROGRAM's data from, and the PID of the child process running +PROGRAM." + ;; 'open-pipe*' doesn't attempt to capture stderr in any way, which is why + ;; we need to roll our own. + (match (pipe) + ((input . output) + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + (close-port input) + (dup2 (fileno output) 1) + (dup2 (fileno output) 2) + (apply execlp program program args)) + (lambda () + (primitive-exit 127)))) + (pid + (close-port output) + (values input pid)))))) + +(define (invoke/quiet program . args) + "Invoke PROGRAM with ARGS and capture PROGRAM's standard output and standard +error. If PROGRAM succeeds, print nothing and return the unspecified value; +otherwise, raise a '&message' error condition that includes the status code +and the output of PROGRAM." + (let-values (((pipe pid) + (apply open-pipe-with-stderr program args))) + (let loop ((lines '())) + (match (read-line pipe) + ((? eof-object?) + (close-port pipe) + (match (waitpid pid) + ((_ . status) + (unless (zero? status) + (let-syntax ((G_ (syntax-rules () ;for xgettext + ((_ str) str)))) + (raise (condition + (&message + (message (format #f (G_ "'~a~{ ~a~}' exited \ +with status ~a; output follows:~%~%~{ ~a~%~}") + program args + (or (status:exit-val status) + status) + (reverse lines))))))))))) + (line + (loop (cons line lines))))))) + ;;; ;;; Text substitution (aka. sed). @@ -987,8 +1085,8 @@ known as `nuke-refs' in Nixpkgs." ;; We cannot use `regexp-exec' here because it cannot deal with ;; strings containing NUL characters. (format #t "removing store references from `~a'...~%" file) - (setvbuf in _IOFBF 65536) - (setvbuf out _IOFBF 65536) + (setvbuf in 'block 65536) + (setvbuf out 'block 65536) (fold-port-matches (lambda (match result) (put-bytevector out (string->utf8 store)) (put-u8 out (char->integer #\/)) @@ -1003,6 +1101,18 @@ known as `nuke-refs' in Nixpkgs." (put-u8 out (char->integer char)) result)))))) +(define-condition-type &wrap-error &error + wrap-error? + (program wrap-error-program) + (type wrap-error-type)) + +(define (wrapper? prog) + "Return #t if PROG is a wrapper as produced by 'wrap-program'." + (and (file-exists? prog) + (let ((base (basename prog))) + (and (string-prefix? "." base) + (string-suffix? "-real" base))))) + (define* (wrap-program prog #:rest vars) "Make a wrapper for PROG. VARS should look like this: @@ -1100,6 +1210,120 @@ with definitions for VARS." (chmod prog-tmp #o755) (rename-file prog-tmp prog)))) +(define wrap-script + (let ((interpreter-regex + (make-regexp + (string-append "^#! ?(/[^ ]+/bin/(" + (string-join '("python[^ ]*" + "Rscript" + "perl" + "ruby" + "bash" + "sh") "|") + "))( ?.*)"))) + (coding-line-regex + (make-regexp + ".*#.*coding[=:][[:space:]]*([-a-zA-Z_0-9.]+)"))) + (lambda* (prog #:key (guile (which "guile")) #:rest vars) + "Wrap the script PROG such that VARS are set first. The format of VARS +is the same as in the WRAP-PROGRAM procedure. This procedure differs from +WRAP-PROGRAM in that it does not create a separate shell script. Instead, +PROG is modified directly by prepending a Guile script, which is interpreted +as a comment in the script's language. + +Special encoding comments as supported by Python are recreated on the second +line. + +Note that this procedure can only be used once per file as Guile scripts are +not supported." + (define update-env + (match-lambda + ((var sep '= rest) + `(setenv ,var ,(string-join rest sep))) + ((var sep 'prefix rest) + `(let ((current (getenv ,var))) + (setenv ,var (if current + (string-append ,(string-join rest sep) + ,sep current) + ,(string-join rest sep))))) + ((var sep 'suffix rest) + `(let ((current (getenv ,var))) + (setenv ,var (if current + (string-append current ,sep + ,(string-join rest sep)) + ,(string-join rest sep))))) + ((var '= rest) + `(setenv ,var ,(string-join rest ":"))) + ((var 'prefix rest) + `(let ((current (getenv ,var))) + (setenv ,var (if current + (string-append ,(string-join rest ":") + ":" current) + ,(string-join rest ":"))))) + ((var 'suffix rest) + `(let ((current (getenv ,var))) + (setenv ,var (if current + (string-append current ":" + ,(string-join rest ":")) + ,(string-join rest ":"))))))) + (let-values (((interpreter args coding-line) + (call-with-ascii-input-file prog + (lambda (p) + (let ((first-match + (false-if-exception + (regexp-exec interpreter-regex (read-line p))))) + (values (and first-match (match:substring first-match 1)) + (and first-match (match:substring first-match 3)) + (false-if-exception + (and=> (regexp-exec coding-line-regex (read-line p)) + (lambda (m) (match:substring m 0)))))))))) + (if interpreter + (let* ((header (format #f "\ +#!~a --no-auto-compile +#!#; ~a +#\\-~s +#\\-~s +" + guile + (or coding-line "Guix wrapper") + (cons 'begin (map update-env + (match vars + ((#:guile _ . vars) vars) + (_ vars)))) + `(let ((cl (command-line))) + (apply execl ,interpreter + (car cl) + (cons (car cl) + (append + ',(string-split args #\space) + cl)))))) + (template (string-append prog ".XXXXXX")) + (out (mkstemp! template)) + (st (stat prog)) + (mode (stat:mode st))) + (with-throw-handler #t + (lambda () + (call-with-ascii-input-file prog + (lambda (p) + (format out header) + (dump-port p out) + (close out) + (chmod template mode) + (rename-file template prog) + (set-file-time prog st)))) + (lambda (key . args) + (format (current-error-port) + "wrap-script: ~a: error: ~a ~s~%" + prog key args) + (false-if-exception (delete-file template)) + (raise (condition + (&wrap-error (program prog) + (type key)))) + #f))) + (raise (condition + (&wrap-error (program prog) + (type 'no-interpreter-found))))))))) + ;;; ;;; Locales. |