diff options
Diffstat (limited to 'guix/build')
| -rw-r--r-- | guix/build/asdf-build-system.scm | 54 | ||||
| -rw-r--r-- | guix/build/cargo-build-system.scm | 13 | ||||
| -rw-r--r-- | guix/build/compile.scm | 3 | ||||
| -rw-r--r-- | guix/build/go-build-system.scm | 7 | ||||
| -rw-r--r-- | guix/build/linux-module-build-system.scm | 11 | ||||
| -rw-r--r-- | guix/build/minify-build-system.scm | 9 | ||||
| -rw-r--r-- | guix/build/syscalls.scm | 22 |
7 files changed, 93 insertions, 26 deletions
diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm index f3f4b49bcf..25dd031962 100644 --- a/guix/build/asdf-build-system.scm +++ b/guix/build/asdf-build-system.scm @@ -85,7 +85,8 @@ valid." ;; files before compiling. (for-each (lambda (file) (let ((s (lstat file))) - (unless (eq? (stat:type s) 'symlink) + (unless (or (eq? (stat:type s) 'symlink) + (not (access? file W_OK))) (utime file 0 0 0 0)))) (find-files source #:directories? #t)) (copy-recursively source target #:keep-mtime? #t) @@ -97,12 +98,53 @@ valid." (find-files target "\\.asd$")) #t)) -(define* (install #:key outputs #:allow-other-keys) - "Copy and symlink all the source files." +(define* (install #:key inputs outputs #:allow-other-keys) + "Copy and symlink all the source files. +The source files are taken from the corresponding compile package (e.g. SBCL) +if it's present in the native-inputs." (define output (assoc-ref outputs "out")) - (copy-files-to-output output - (package-name->name+version - (strip-store-file-name output)))) + (define package-name + (package-name->name+version + (strip-store-file-name output))) + (define (no-prefix pkgname) + (if (string-index pkgname #\-) + (string-drop pkgname (1+ (string-index pkgname #\-))) + pkgname)) + (define parent + (match (assoc package-name inputs + (lambda (key alist-car) + (let* ((alt-key (no-prefix key)) + (alist-car (no-prefix alist-car))) + (or (string=? alist-car key) + (string=? alist-car alt-key))))) + (#f #f) + (p (cdr p)))) + (define parent-name + (and parent + (package-name->name+version (strip-store-file-name parent)))) + (define parent-source + (and parent + (string-append parent "/share/common-lisp/" + (string-take parent-name + (string-index parent-name #\-)) + "-source"))) + + (define (first-subdirectory directory) ; From gnu-build-system. + "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 source-directory + (if (and parent-source + (file-exists? parent-source)) + (string-append parent-source "/" (first-subdirectory parent-source)) + ".")) + + (with-directory-excursion source-directory + (copy-files-to-output output package-name))) (define* (copy-source #:key outputs asd-system-name #:allow-other-keys) "Copy the source to the library output." diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 0721989589..95e8dd772a 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com> ;;; Copyright © 2019, 2020 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -140,11 +141,14 @@ directory = '" port) (define* (build #:key skip-build? + features (cargo-build-flags '("--release")) #:allow-other-keys) "Build a given Cargo package." (or skip-build? - (apply invoke `("cargo" "build" ,@cargo-build-flags)))) + (apply invoke "cargo" "build" + "--features" (string-join features) + cargo-build-flags))) (define* (check #:key tests? @@ -152,10 +156,10 @@ directory = '" port) #:allow-other-keys) "Run tests for a given Cargo package." (if tests? - (apply invoke `("cargo" "test" ,@cargo-test-flags)) + (apply invoke "cargo" "test" cargo-test-flags) #t)) -(define* (install #:key inputs outputs skip-build? #:allow-other-keys) +(define* (install #:key inputs outputs skip-build? features #:allow-other-keys) "Install a given Cargo package." (let* ((out (assoc-ref outputs "out"))) (mkdir-p out) @@ -168,7 +172,8 @@ directory = '" port) ;; otherwise cargo will raise an error. (or skip-build? (not (has-executable-target?)) - (invoke "cargo" "install" "--path" "." "--root" out)))) + (invoke "cargo" "install" "--path" "." "--root" out + "--features" (string-join features))))) (define %standard-phases (modify-phases gnu:%standard-phases diff --git a/guix/build/compile.scm b/guix/build/compile.scm index 63f24fa7d4..ea7e1d2d03 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -98,7 +98,8 @@ (define (override-option option value lst) `(,option ,value ,@(strip-option option lst))) - (cond ((string-contains file "gnu/packages/") + (cond ((or (string-contains file "gnu/packages/") + (string-contains file "gnu/tests/")) ;; Level 0 is good enough but partial evaluation helps preserve the ;; "macro writer's bill of rights". (override-option #:partial-eval? #t diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index 0d15f978cd..b9cb2bfd7b 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2017, 2019 Leo Famulari <leo@famulari.name> ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2020 Jack Hill <jackhill@jackhill.us> +;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -214,18 +215,18 @@ unpacking." (_ #f)) inputs)))) -(define* (build #:key import-path #:allow-other-keys) +(define* (build #:key import-path build-flags #:allow-other-keys) "Build the package named by IMPORT-PATH." (with-throw-handler #t (lambda _ - (invoke "go" "install" + (apply invoke "go" "install" "-v" ; print the name of packages as they are compiled "-x" ; print each command as it is invoked ;; Respectively, strip the symbol table and debug ;; information, and the DWARF symbol table. "-ldflags=-s -w" - import-path)) + `(,@build-flags ,import-path))) (lambda (key . args) (display (string-append "Building '" import-path "' failed.\n" "Here are the results of `go env`:\n")) diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm index 73d6b101f6..d51d76f94b 100644 --- a/guix/build/linux-module-build-system.scm +++ b/guix/build/linux-module-build-system.scm @@ -58,12 +58,13 @@ ;; This block was copied from make-linux-libre--only took the "modules_install" ;; part. -(define* (install #:key inputs native-inputs outputs #:allow-other-keys) +(define* (install #:key make-flags inputs native-inputs outputs + #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (moddir (string-append out "/lib/modules"))) ;; Install kernel modules (mkdir-p moddir) - (invoke "make" "-C" + (apply invoke "make" "-C" (string-append (assoc-ref inputs "linux-module-builder") "/lib/modules/build") (string-append "M=" (getcwd)) @@ -76,7 +77,8 @@ (string-append "INSTALL_PATH=" out) (string-append "INSTALL_MOD_PATH=" out) "INSTALL_MOD_STRIP=1" - "modules_install"))) + "modules_install" + (or make-flags '())))) (define %standard-phases (modify-phases gnu:%standard-phases @@ -84,7 +86,8 @@ (replace 'build build) (replace 'install install))) -(define* (linux-module-build #:key inputs (phases %standard-phases) +(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." diff --git a/guix/build/minify-build-system.scm b/guix/build/minify-build-system.scm index 563def88e9..92158a033f 100644 --- a/guix/build/minify-build-system.scm +++ b/guix/build/minify-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -54,8 +55,12 @@ (let* ((out (assoc-ref outputs "out")) (js (string-append out "/share/javascript/"))) (mkdir-p js) - (for-each (cut install-file <> js) - (find-files "guix/build" "\\.min\\.js$"))) + (for-each + (lambda (file) + (if (not (zero? (stat:size (stat file)))) + (install-file file js) + (error "File is empty: " file))) + (find-files "guix/build" "\\.min\\.js$"))) #t) (define %standard-phases diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 8070c5546f..85c1c45f81 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1218,7 +1218,7 @@ handler if the lock is already held by another process." ;; zero. 16) -(define (set-thread-name name) +(define (set-thread-name!/linux name) "Set the name of the calling thread to NAME. NAME is truncated to 15 bytes." (let ((ptr (string->pointer name))) @@ -1231,7 +1231,7 @@ bytes." (list (strerror err)) (list err)))))) -(define (thread-name) +(define (thread-name/linux) "Return the name of the calling thread as a string." (let ((buf (make-bytevector %max-thread-name-length))) (let-values (((ret err) @@ -1245,6 +1245,16 @@ bytes." (list (strerror err)) (list err)))))) +(define set-thread-name + (if (string-contains %host-type "linux") + set-thread-name!/linux + (const #f))) + +(define thread-name + (if (string-contains %host-type "linux") + thread-name/linux + (const ""))) + ;;; ;;; Network interfaces. @@ -1404,7 +1414,7 @@ bytevector BV at INDEX." (error "unsupported socket address" sockaddr))))) (define write-socket-address! - (if (string-suffix? "linux-gnu" %host-type) + (if (string-contains %host-type "linux-gnu") write-socket-address!/linux write-socket-address!/hurd)) @@ -1436,7 +1446,7 @@ bytevector BV at INDEX." (vector family))))) (define read-socket-address - (if (string-suffix? "linux-gnu" %host-type) + (if (string-contains %host-type "linux-gnu") read-socket-address/linux read-socket-address/hurd)) @@ -2052,8 +2062,8 @@ correspond to a terminal, return the value returned by FALL-BACK." ;; would return EINVAL instead in some cases: ;; <https://bugs.ruby-lang.org/issues/10494>. ;; Furthermore, some FUSE file systems like unionfs return ENOSYS for - ;; that ioctl. - (if (memv errno (list ENOTTY EINVAL ENOSYS)) + ;; that ioctl, and bcachefs returns EPERM. + (if (memv errno (list ENOTTY EINVAL ENOSYS EPERM)) (fall-back) (apply throw args)))))) |