Merge branch 'core-updates'

9 files changed, 236 insertions, 38 deletions

diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm
index 25ac262d5d..ee116c5a4c 100644
--- a/guix/build-system/cmake.scm
+++ b/guix/build-system/cmake.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com>
+;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -56,24 +57,38 @@
                 #:rest arguments)
   "Return a bag for NAME."
   (define private-keywords
-    '(#:source #:target #:cmake #:inputs #:native-inputs))
-
-  (and (not target)                               ;XXX: no cross-compilation
-       (bag
-         (name name)
-         (system system)
-         (host-inputs `(,@(if source
-                              `(("source" ,source))
-                              '())
-                        ,@inputs
-
-                        ;; Keep the standard inputs of 'gnu-build-system'.
-                        ,@(standard-packages)))
-         (build-inputs `(("cmake" ,cmake)
-                         ,@native-inputs))
-         (outputs outputs)
-         (build cmake-build)
-         (arguments (strip-keyword-arguments private-keywords arguments)))))
+    `(#:source #:cmake #:inputs #:native-inputs #:outputs
+      ,@(if target '() '(#:target))))
+
+  (bag
+    (name name)
+    (system system)
+    (target target)
+    (build-inputs `(,@(if source
+                          `(("source" ,source))
+                          '())
+                    ,@`(("cmake" ,cmake))
+                    ,@native-inputs
+                    ,@(if target
+                          ;; Use the standard cross inputs of
+                          ;; 'gnu-build-system'.
+                          (standard-cross-packages target 'host)
+                          '())
+                    ;; Keep the standard inputs of 'gnu-build-system'.
+                    ,@(standard-packages)))
+    (host-inputs inputs)
+
+    ;; The cross-libc is really a target package, but for bootstrapping
+    ;; reasons, we can't put it in 'host-inputs'.  Namely, 'cross-gcc' is a
+    ;; native package, so it would end up using a "native" variant of
+    ;; 'cross-libc' (built with 'gnu-build'), whereas all the other packages
+    ;; would use a target variant (built with 'gnu-cross-build'.)
+    (target-inputs (if target
+                       (standard-cross-packages target 'target)
+                       '()))
+    (outputs outputs)
+    (build (if target cmake-cross-build cmake-build))
+    (arguments (strip-keyword-arguments private-keywords arguments))))
 
 (define* (cmake-build store name inputs
                       #:key (guile #f)
@@ -145,6 +160,115 @@ provides a 'CMakeLists.txt' file as its build system."
                                 #:outputs outputs
                                 #:guile-for-build guile-for-build))
 
+
+;;;
+;;; Cross-compilation.
+;;;
+
+(define* (cmake-cross-build store name
+                            #:key
+                            target native-drvs target-drvs
+                            (guile #f)
+                            (outputs '("out"))
+                            (configure-flags ''())
+                            (search-paths '())
+                            (native-search-paths '())
+                            (make-flags ''())
+                            (out-of-source? #t)
+                            (build-type "RelWithDebInfo")
+                            (tests? #f) ; nothing can be done
+                            (test-target "test")
+                            (parallel-build? #t) (parallel-tests? #f)
+                            (validate-runpath? #t)
+                            (patch-shebangs? #t)
+                            (strip-binaries? #t)
+                            (strip-flags ''("--strip-debug"
+                                            "--enable-deterministic-archives"))
+                            (strip-directories ''("lib" "lib64" "libexec"
+                                                  "bin" "sbin"))
+                            (phases '(@ (guix build cmake-build-system)
+                                        %standard-phases))
+                            (system (%current-system))
+                            (build (nix-system->gnu-triplet system))
+                            (imported-modules %cmake-build-system-modules)
+                            (modules '((guix build cmake-build-system)
+                                       (guix build utils))))
+  "Cross-build NAME using CMAKE for TARGET, where TARGET is a GNU triplet and
+with INPUTS.  This assumes that SOURCE provides a 'CMakeLists.txt' file as its
+build system."
+  (define builder
+    `(begin
+       (use-modules ,@modules)
+       (let ()
+         (define %build-host-inputs
+           ',(map (match-lambda
+                    ((name (? derivation? drv) sub ...)
+                     `(,name . ,(apply derivation->output-path drv sub)))
+                    ((name path)
+                     `(,name . ,path)))
+                  native-drvs))
+
+         (define %build-target-inputs
+           ',(map (match-lambda
+                    ((name (? derivation? drv) sub ...)
+                     `(,name . ,(apply derivation->output-path drv sub)))
+                    ((name (? package? pkg) sub ...)
+                     (let ((drv (package-cross-derivation store pkg
+                                                          target system)))
+                       `(,name . ,(apply derivation->output-path drv sub))))
+                    ((name path)
+                     `(,name . ,path)))
+                  target-drvs))
+
+         (cmake-build #:source ,(match (assoc-ref native-drvs "source")
+                                  (((? derivation? source))
+                                   (derivation->output-path source))
+                                  ((source)
+                                   source)
+                                  (source
+                                   source))
+                      #:system ,system
+                      #:build ,build
+                      #:target ,target
+                      #:outputs %outputs
+                      #:inputs %build-target-inputs
+                      #:native-inputs %build-host-inputs
+                      #:search-paths ',(map search-path-specification->sexp
+                                            search-paths)
+                      #:native-search-paths ',(map
+                                               search-path-specification->sexp
+                                               native-search-paths)
+                      #:phases ,phases
+                      #:configure-flags ,configure-flags
+                      #:make-flags ,make-flags
+                      #:out-of-source? ,out-of-source?
+                      #:build-type ,build-type
+                      #:tests? ,tests?
+                      #:test-target ,test-target
+                      #:parallel-build? ,parallel-build?
+                      #:parallel-tests? ,parallel-tests?
+                      #:validate-runpath? ,validate-runpath?
+                      #:patch-shebangs? ,patch-shebangs?
+                      #:strip-binaries? ,strip-binaries?
+                      #:strip-flags ,strip-flags
+                      #:strip-directories ,strip-directories))))
+
+  (define guile-for-build
+    (match guile
+      ((? package?)
+       (package-derivation store guile system #:graft? #f))
+      (#f                               ; the default
+       (let* ((distro (resolve-interface '(gnu packages commencement)))
+              (guile  (module-ref distro 'guile-final)))
+         (package-derivation store guile system #:graft? #f)))))
+
+  (build-expression->derivation store name builder
+                                #:system system
+                                #:inputs (append native-drvs target-drvs)
+                                #:outputs outputs
+                                #:modules imported-modules
+                                #:guile-for-build guile-for-build))
+
 (define cmake-build-system
   (build-system
     (name 'cmake)
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index 7cf0cafc0f..047ace7e6b 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -30,6 +30,7 @@
             gnu-build
             gnu-build-system
             standard-packages
+            standard-cross-packages
             package-with-explicit-inputs
             package-with-extra-configure-variable
             static-libgcc-package
diff --git a/guix/build/cmake-build-system.scm b/guix/build/cmake-build-system.scm
index 27f2b5c872..128ab28fe5 100644
--- a/guix/build/cmake-build-system.scm
+++ b/guix/build/cmake-build-system.scm
@@ -32,7 +32,7 @@
 ;; Code:
 
 (define* (configure #:key outputs (configure-flags '()) (out-of-source? #t)
-                    build-type
+                    build-type target
                     #:allow-other-keys)
   "Configure the given package."
   (let* ((out        (assoc-ref outputs "out"))
@@ -59,6 +59,15 @@
                   ,(string-append "-DCMAKE_INSTALL_RPATH=" out "/lib")
                   ;; enable verbose output from builds
                   "-DCMAKE_VERBOSE_MAKEFILE=ON"
+
+                  ;;  Cross-build
+                  ,@(if target
+                        (list (string-append "-DCMAKE_C_COMPILER="
+                                             target "-gcc")
+                              (if (string-contains target "mingw")
+                                  "-DCMAKE_SYSTEM_NAME=Windows"
+                                  "-DCMAKE_SYSTEM_NAME=Linux"))
+                        '())
                   ,@configure-flags)))
       (format #t "running 'cmake' with arguments ~s~%" args)
       (zero? (apply system* "cmake" args)))))
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 1786e2e3c9..e37b751403 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -39,6 +39,13 @@
 ;;
 ;; Code:
 
+(cond-expand
+  (guile-2.2
+   ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
+   ;; nanoseconds swapped (fixed in Guile commit 886ac3e).  Work around it.
+   (define time-monotonic time-tai))
+  (else #t))
+
 (define* (set-SOURCE-DATE-EPOCH #:rest _)
   "Set the 'SOURCE_DATE_EPOCH' environment variable.  This is used by tools
 that incorporate timestamps as a way to tell them to use a fixed timestamp.
@@ -521,6 +528,25 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
     ;; Return #t if FILE has hard links.
     (> (stat:nlink (lstat file)) 1))
 
+  (define (points-to-symlink? symlink)
+    ;; Return #t if SYMLINK points to another symbolic link.
+    (let* ((target (readlink symlink))
+           (target-absolute (if (string-prefix? "/" target)
+                                target
+                                (string-append (dirname symlink)
+                                               "/" target))))
+      (catch 'system-error
+        (lambda ()
+          (symbolic-link? target-absolute))
+        (lambda args
+          (if (= ENOENT (system-error-errno args))
+              (begin
+                (format (current-error-port)
+                        "The symbolic link '~a' target is missing: '~a'\n"
+                        symlink target-absolute)
+                #f)
+              (apply throw args))))))
+
   (define (maybe-compress-directory directory regexp)
     (or (not (directory-exists? directory))
         (match (find-files directory regexp)
@@ -538,12 +564,17 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
                ;; Compress the non-symlink files, and adjust symlinks to refer
                ;; to the compressed files.  Leave files that have hard links
                ;; unchanged ('gzip' would refuse to compress them anyway.)
-               (and (zero? (apply system* documentation-compressor
-                                  (append documentation-compressor-flags
-                                          (remove has-links? regular-files))))
-                    (every retarget-symlink
-                           (filter (cut string-match regexp <>)
-                                   symlinks)))))))))
+               ;; Also, do not retarget symbolic links pointing to other
+               ;; symbolic links, since these are not compressed.
+               (and (every retarget-symlink
+                           (filter (lambda (symlink)
+                                     (and (not (points-to-symlink? symlink))
+                                          (string-match regexp symlink)))
+                                   symlinks))
+                    (zero?
+                     (apply system* documentation-compressor
+                            (append documentation-compressor-flags
+                                    (remove has-links? regular-files)))))))))))
 
   (define (maybe-compress output)
     (and (maybe-compress-directory (string-append output "/share/man")
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 33a23edaac..55b0df3911 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -726,15 +726,19 @@ mounted at FILE."
 (cond-expand
   (guile-2.2
    (define %set-automatic-finalization-enabled?!
-     (let ((proc (pointer->procedure int
-                                     (dynamic-func
-                                      "scm_set_automatic_finalization_enabled"
-                                      (dynamic-link))
-                                     (list int))))
+     ;; When using a statically-linked Guile, for instance in the initrd, we
+     ;; cannot resolve this symbol, but most of the time we don't need it
+     ;; anyway.  Thus, delay it.
+     (let ((proc (delay
+                   (pointer->procedure int
+                                       (dynamic-func
+                                        "scm_set_automatic_finalization_enabled"
+                                        (dynamic-link))
+                                       (list int)))))
        (lambda (enabled?)
          "Switch on or off automatic finalization in a separate thread.
 Turning finalization off shuts down the finalization thread as a side effect."
-         (->bool (proc (if enabled? 1 0))))))
+         (->bool ((force proc) (if enabled? 1 0))))))
 
    (define-syntax-rule (without-automatic-finalization exp)
      "Turn off automatic finalization within the dynamic extent of EXP."
diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index e8efb0653a..7391307c87 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -32,7 +32,12 @@
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
   #:re-export (alist-cons
-               alist-delete)
+               alist-delete
+
+               ;; Note: Re-export 'delete' to allow for proper syntax matching
+               ;; in 'modify-phases' forms.  See
+               ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=26805#16>.
+               delete)
   #:export (%store-directory
             store-file-name?
             strip-store-file-name
@@ -79,6 +84,7 @@
             fold-port-matches
             remove-store-references
             wrap-program
+            invoke
 
             locale-category->string))
 
@@ -574,6 +580,15 @@ 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))))
 
+(define (invoke program . args)
+  "Invoke PROGRAM with the given ARGS.  Raise an error if the exit
+code is non-zero; otherwise return #t."
+  (let ((status (apply system* program args)))
+    (unless (zero? status)
+      (error (format #f "program ~s exited with non-zero code" program)
+             status))
+    #t))
+
 
 ;;;
 ;;; Text substitution (aka. sed).
diff --git a/guix/download.scm b/guix/download.scm
index bf818e3cdf..ae381ee7ab 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -115,7 +115,7 @@
        "http://jaist.dl.sourceforge.net/project/"
        "http://kent.dl.sourceforge.net/project/"
        "http://liquidtelecom.dl.sourceforge.net/project/"
-       "http://nbtelecom.dl.sourceforge.net/project/"
+       ;; "http://nbtelecom.dl.sourceforge.net/project/"  ;never returns 404s
        "http://nchc.dl.sourceforge.net/project/"
        "http://ncu.dl.sourceforge.net/project/"
        "http://netcologne.dl.sourceforge.net/project/"
diff --git a/guix/packages.scm b/guix/packages.scm
index f60303404f..f619d9b370 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -414,6 +414,13 @@ derivations."
   (let ((distro (resolve-interface '(gnu packages commencement))))
     (module-ref distro 'guile-final)))
 
+(define (guile-2.0)
+  "Return Guile 2.0."
+  ;; FIXME: This is used as a workaround for <https://bugs.gnu.org/28211> when
+  ;; grafting packages.
+  (let ((distro (resolve-interface '(gnu packages guile))))
+    (module-ref distro 'guile-2.0)))
+
 (define* (default-guile-derivation #:optional (system (%current-system)))
   "Return the derivation for SYSTEM of the default Guile package used to run
 the build code of derivation."
@@ -581,7 +588,12 @@ specifies modules in scope when evaluating SNIPPET."
                                                     #:fail-on-error? #t)))))
                         (zero? (apply system*
                                       (string-append #+tar "/bin/tar")
-                                      "cvfa" #$output
+                                      "cvf" #$output
+                                      ;; The bootstrap xz does not support
+                                      ;; threaded compression (introduced in
+                                      ;; 5.2.0), but it ignores the extra flag.
+                                      (string-append "--use-compress-program="
+                                                     #+xz "/bin/xz --threads=0")
                                       ;; avoid non-determinism in the archive
                                       "--mtime=@0"
                                       "--owner=root:0"
@@ -1140,7 +1152,7 @@ This is an internal procedure."
                   (()
                    drv)
                   (grafts
-                   (let ((guile (package-derivation store (default-guile)
+                   (let ((guile (package-derivation store (guile-2.0)
                                                     system #:graft? #f)))
                      ;; TODO: As an optimization, we can simply graft the tip
                      ;; of the derivation graph since 'graft-derivation'
@@ -1166,7 +1178,7 @@ system identifying string)."
                    (graft-derivation store drv grafts
                                      #:system system
                                      #:guile
-                                     (package-derivation store (default-guile)
+                                     (package-derivation store (guile-2.0)
                                                          system #:graft? #f))))
                 drv))))
 
diff --git a/guix/profiles.scm b/guix/profiles.scm
index b3732f61ed..0eb99f40de 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1095,9 +1095,11 @@ files for the fonts of the @var{manifest} entries."
                                 (unless (and (zero? (system* mkfontscale))
                                              (zero? (system* mkfontdir)))
                                   (exit #f))
-                                (when (empty-file? fonts-scale-file)
+                                (when (and (file-exists? fonts-scale-file)
+                                           (empty-file? fonts-scale-file))
                                   (delete-file fonts-scale-file))
-                                (when (empty-file? fonts-dir-file)
+                                (when (and (file-exists? fonts-dir-file)
+                                           (empty-file? fonts-dir-file))
                                   (delete-file fonts-dir-file))))
                             directories)))))))