diff options
author | Ludovic Courtès <ludo@gnu.org> | 2019-06-13 13:24:35 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2019-06-13 13:24:35 +0200 |
commit | d9bbfe042e06df35c12e4b8f53bfb1889cba90bf (patch) | |
tree | 9f34077cd824e8955be4ed2b5f1a459aa8076489 /guix/build | |
parent | f87a7cc60e058d2e07560d0d602747b567d9dce4 (diff) | |
parent | 47f2168b6fabb105565526b2a1243eeeb13008fe (diff) | |
download | guix-patches-d9bbfe042e06df35c12e4b8f53bfb1889cba90bf.tar guix-patches-d9bbfe042e06df35c12e4b8f53bfb1889cba90bf.tar.gz |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix/build')
-rw-r--r-- | guix/build/cargo-build-system.scm | 54 | ||||
-rw-r--r-- | guix/build/compile.scm | 8 | ||||
-rw-r--r-- | guix/build/guile-build-system.scm | 52 | ||||
-rw-r--r-- | guix/build/syscalls.scm | 40 |
4 files changed, 110 insertions, 44 deletions
diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 9f44bd6ee9..1f36304b15 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -54,6 +54,22 @@ (bin-dep? (lambda (dep) (find bin? (get-kinds dep))))) (find bin-dep? (manifest-targets)))) +(define (crate-src? path) + "Check if PATH refers to a crate source, namely a gzipped tarball with a +Cargo.toml file present at its root." + (and (gzip-file? path) + ;; First we print out all file names within the tarball to see if it + ;; looks like the source of a crate. However, the tarball will include + ;; an extra path component which we would like to ignore (since we're + ;; interested in checking if a Cargo.toml exists at the root of the + ;; 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$'")))))) + (define* (configure #:key inputs (vendor-dir "guix-vendor") #:allow-other-keys) @@ -67,14 +83,21 @@ (for-each (match-lambda ((name . path) - (let* ((rust-share (string-append path "/share/rust-source")) - (basepath (basename path)) - (link-dir (string-append vendor-dir "/" basepath))) - (and (file-exists? rust-share) + (let* ((basepath (basename path)) + (crate-dir (string-append vendor-dir "/" basepath))) + (and (crate-src? path) ;; Gracefully handle duplicate inputs - (not (file-exists? link-dir)) - (symlink rust-share link-dir))))) + (not (file-exists? crate-dir)) + (mkdir-p crate-dir) + ;; Cargo crates are simply gzipped tarballs but with a .crate + ;; extension. We expand the source to a directory name we control + ;; so that we can generate any cargo checksums. + ;; The --strip-components argument is needed to prevent creating + ;; an extra directory within `crate-dir`. + (invoke "tar" "xvf" path "-C" crate-dir "--strip-components" "1") + (generate-checksums crate-dir))))) inputs) + ;; Configure cargo to actually use this new directory. (mkdir-p ".cargo") (let ((port (open-file ".cargo/config" "w" #:encoding "utf-8"))) @@ -117,24 +140,6 @@ directory = '" port) (define (touch file-name) (call-with-output-file file-name (const #t))) -(define* (install-source #:key inputs outputs #:allow-other-keys) - "Install the source for a given Cargo package." - (let* ((out (assoc-ref outputs "out")) - (src (assoc-ref inputs "source")) - (rsrc (string-append (assoc-ref outputs "src") - "/share/rust-source"))) - (mkdir-p rsrc) - ;; Rust doesn't have a stable ABI yet. Because of this - ;; Cargo doesn't have a search path for binaries yet. - ;; Until this changes we are working around this by - ;; vendoring the crates' sources by symlinking them - ;; to store paths. - (copy-recursively "." rsrc) - (touch (string-append rsrc "/.cargo-ok")) - (generate-checksums rsrc) - (install-file "Cargo.toml" rsrc) - #t)) - (define* (install #:key inputs outputs skip-build? #:allow-other-keys) "Install a given Cargo package." (let* ((out (assoc-ref outputs "out"))) @@ -156,7 +161,6 @@ directory = '" port) (define %standard-phases (modify-phases gnu:%standard-phases (delete 'bootstrap) - (add-before 'configure 'install-source install-source) (replace 'configure configure) (replace 'build build) (replace 'check check) diff --git a/guix/build/compile.scm b/guix/build/compile.scm index 9e31be93ff..794f12379c 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -40,8 +40,12 @@ (define %default-optimizations ;; Default optimization options (equivalent to -O2 on Guile 2.2). - (append (tree-il-default-optimization-options) - (cps-default-optimization-options))) + (append (if (defined? 'tree-il-default-optimization-options) + (tree-il-default-optimization-options) ;Guile 2.2 + (tree-il-optimizations)) ;Guile 3 + (if (defined? 'cps-default-optimization-options) + (cps-default-optimization-options) ;Guile 2.2 + (cps-optimizations)))) ;Guile 3 (define %lightweight-optimizations ;; Lightweight optimizations (like -O0, but with partial evaluation). diff --git a/guix/build/guile-build-system.scm b/guix/build/guile-build-system.scm index 31f0d3d6f4..32a431d347 100644 --- a/guix/build/guile-build-system.scm +++ b/guix/build/guile-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,10 +19,13 @@ (define-module (guix build guile-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) #:use-module (guix build utils) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (ice-9 format) #:use-module (guix build utils) #:export (target-guile-effective-version %standard-phases @@ -74,11 +77,19 @@ Raise an error if one of the processes exit with non-zero." (define total (length commands)) + (define processes + (make-hash-table)) + (define (wait-for-one-process) (match (waitpid WAIT_ANY) - ((_ . status) - (unless (zero? (status:exit-val status)) - (error "process failed" status))))) + ((pid . status) + (let ((command (hashv-ref processes pid))) + (hashv-remove! processes command) + (unless (zero? (status:exit-val status)) + (format (current-error-port) + "process '~{~a ~}' failed with status ~a~%" + command status) + (exit 1)))))) (define (fork-and-run-command command) (match (primitive-fork) @@ -90,6 +101,7 @@ Raise an error if one of the processes exit with non-zero." (lambda () (primitive-exit 127)))) (pid + (hashv-set! processes pid command) #t))) (let loop ((commands commands) @@ -117,17 +129,20 @@ Raise an error if one of the processes exit with non-zero." (define* (report-build-progress total completed #:optional (log-port (current-error-port))) "Report that COMPLETED out of TOTAL files have been completed." - (format log-port "compiling...\t~5,1f% of ~d files~%" ;FIXME: i18n - (* 100. (/ completed total)) total) + (format log-port "[~2d/~2d] Compiling...~%" + completed total) (force-output log-port)) (define* (build #:key outputs inputs native-inputs (source-directory ".") (compile-flags '()) (scheme-file-regexp %scheme-file-regexp) + (not-compiled-file-regexp #f) target #:allow-other-keys) - "Build files in SOURCE-DIRECTORY that match SCHEME-FILE-REGEXP." + "Build files in SOURCE-DIRECTORY that match SCHEME-FILE-REGEXP. Files +matching NOT-COMPILED-FILE-REGEXP, if true, are not compiled but are +installed; this is useful for files that are meant to be included." (let* ((out (assoc-ref outputs "out")) (guile (assoc-ref (or native-inputs inputs) "guile")) (effective (target-guile-effective-version guile)) @@ -162,16 +177,19 @@ Raise an error if one of the processes exit with non-zero." (with-directory-excursion source-directory (find-files "." scheme-file-regexp)))) (invoke-each - (map (lambda (file) - (cons* guild - "guild" "compile" - "-L" source-directory - "-o" (string-append go-dir - (file-sans-extension file) - ".go") - (string-append source-directory "/" file) - flags)) - source-files) + (filter-map (lambda (file) + (and (or (not not-compiled-file-regexp) + (not (string-match not-compiled-file-regexp + file))) + (cons* guild + "guild" "compile" + "-L" source-directory + "-o" (string-append go-dir + (file-sans-extension file) + ".go") + (string-append source-directory "/" file) + flags))) + source-files) #:max-processes (parallel-job-count) #:report-progress report-build-progress) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 3abe65bc4f..5c2eb3c14d 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -81,7 +81,11 @@ fdatasync pivot-root scandir* + fcntl-flock + lock-file + unlock-file + with-file-lock set-thread-name thread-name @@ -1067,6 +1071,42 @@ exception if it's already taken." ;; Presumably we got EAGAIN or so. (throw 'flock-error err)))))) +(define (lock-file file) + "Wait and acquire an exclusive lock on FILE. Return an open port." + (let ((port (open-file file "w0"))) + (fcntl-flock port 'write-lock) + port)) + +(define (unlock-file port) + "Unlock PORT, a port returned by 'lock-file'." + (fcntl-flock port 'unlock) + (close-port port) + #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)))))) + (dynamic-wind + (lambda () + #t) + thunk + (lambda () + (when port + (unlock-file port)))))) + +(define-syntax-rule (with-file-lock file exp ...) + "Wait to acquire a lock on FILE and evaluate EXP in that context." + (call-with-file-lock file (lambda () exp ...))) + ;;; ;;; Miscellaneous, aka. 'prctl'. |