summaryrefslogtreecommitdiff
path: root/guix/build
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2019-10-08 19:24:34 +0200
committerMarius Bakke <mbakke@fastmail.com>2019-10-08 19:24:34 +0200
commitd1f3b333e6176a7879ab3742bbebb2a99f61a528 (patch)
tree8bd82ce68bd2534a48bf13c7256997f82dd1b3f4 /guix/build
parente01d384efcdaf564bbb221e43b81e087c8e2af06 (diff)
parent861907f01efb1cae7f260e8cb7b991d5034a486a (diff)
downloadguix-patches-d1f3b333e6176a7879ab3742bbebb2a99f61a528.tar
guix-patches-d1f3b333e6176a7879ab3742bbebb2a99f61a528.tar.gz
Merge branch 'master' into staging
Diffstat (limited to 'guix/build')
-rw-r--r--guix/build/cargo-build-system.scm38
-rw-r--r--guix/build/compile.scm9
-rw-r--r--guix/build/gnu-build-system.scm130
-rw-r--r--guix/build/go-build-system.scm2
-rw-r--r--guix/build/julia-build-system.scm135
-rw-r--r--guix/build/lisp-utils.scm14
-rw-r--r--guix/build/make-bootstrap.scm72
-rw-r--r--guix/build/meson-build-system.scm1
-rw-r--r--guix/build/python-build-system.scm33
-rw-r--r--guix/build/ruby-build-system.scm2
-rw-r--r--guix/build/syscalls.scm44
-rw-r--r--guix/build/utils.scm230
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.