Merge branch 'master' into core-updates

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'.