Merge branch 'core-updates'

5 files changed, 176 insertions, 201 deletions

diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index 35590aa3da..c12a871fd8 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -41,42 +41,64 @@
 ;;
 ;; Code:
 
-(define* (package-with-explicit-inputs p boot-inputs
+(define* (package-with-explicit-inputs p inputs
                                        #:optional
                                        (loc (current-source-location))
-                                       #:key guile)
-  "Rewrite P, which is assumed to use GNU-BUILD-SYSTEM, to take
-BOOT-INPUTS as explicit inputs instead of the implicit default, and
-return it.  Use GUILE to run the builder, or the distro's final Guile
-when GUILE is #f."
-  (define rewritten-input
-    (match-lambda
-     ((name (? package? p) sub-drv ...)
-      (cons* name
-             (package-with-explicit-inputs p boot-inputs #:guile guile)
-             sub-drv))
-     (x x)))
-
-  (define boot-input-names
-    (map car boot-inputs))
+                                       #:key (native-inputs '())
+                                       guile)
+  "Rewrite P, which is assumed to use GNU-BUILD-SYSTEM, to take INPUTS and
+NATIVE-INPUTS as explicit inputs instead of the implicit default, and return
+it.  INPUTS and NATIVE-INPUTS can be either input lists or thunks; in the
+latter case, they will be called in a context where the `%current-system' and
+`%current-target-system' are suitably parametrized.  Use GUILE to run the
+builder, or the distro's final Guile when GUILE is #f."
+  (define inputs* inputs)
+  (define native-inputs* native-inputs)
+
+  (define (call inputs)
+    (if (procedure? inputs)
+        (inputs)
+        inputs))
+
+  (define (duplicate-filter inputs)
+    (let ((names (match (call inputs)
+                   (((name _ ...) ...)
+                    name))))
+      (lambda (inputs)
+        (fold alist-delete inputs names))))
 
-  (define (filtered-inputs inputs)
-    (fold alist-delete inputs boot-input-names))
+  (let loop ((p p))
+    (define rewritten-input
+      (memoize
+       (match-lambda
+        ((name (? package? p) sub-drv ...)
+         ;; XXX: Check whether P's build system knows #:implicit-inputs, for
+         ;; things like `cross-pkg-config'.
+         (if (eq? (package-build-system p) gnu-build-system)
+             (cons* name (loop p) sub-drv)
+             (cons* name p sub-drv)))
+        (x x))))
 
-  (package (inherit p)
-    (location (if (pair? loc) (source-properties->location loc) loc))
-    (arguments
-     (let ((args (package-arguments p)))
-       `(#:guile ,guile
-         #:implicit-inputs? #f ,@args)))
-    (native-inputs (map rewritten-input
-                        (filtered-inputs (package-native-inputs p))))
-    (propagated-inputs (map rewritten-input
-                            (filtered-inputs
-                             (package-propagated-inputs p))))
-    (inputs `(,@boot-inputs
-              ,@(map rewritten-input
-                     (filtered-inputs (package-inputs p)))))))
+    (package (inherit p)
+      (location (if (pair? loc) (source-properties->location loc) loc))
+      (arguments
+       (let ((args (package-arguments p)))
+         `(#:guile ,guile
+           #:implicit-inputs? #f
+           ,@args)))
+      (native-inputs
+       (let ((filtered (duplicate-filter native-inputs*)))
+        `(,@(call native-inputs*)
+          ,@(map rewritten-input
+                 (filtered (package-native-inputs p))))))
+      (propagated-inputs
+       (map rewritten-input
+            (package-propagated-inputs p)))
+      (inputs
+       (let ((filtered (duplicate-filter inputs*)))
+         `(,@(call inputs*)
+           ,@(map rewritten-input
+                  (filtered (package-inputs p)))))))))
 
 (define (package-with-extra-configure-variable p variable value)
   "Return a version of P with VARIABLE=VALUE specified as an extra `configure'
@@ -277,7 +299,9 @@ which could lead to gratuitous input divergence."
                                   ,@(if implicit-inputs?
                                         implicit-inputs
                                         '()))
-                                #:outputs outputs
+                                #:outputs (if strip-binaries?
+                                              outputs
+                                              (delete "debug" outputs))
                                 #:modules imported-modules
                                 #:guile-for-build guile-for-build))
 
@@ -332,7 +356,7 @@ inputs."
                           (make-flags ''())
                           (patches ''()) (patch-flags ''("--batch" "-p1"))
                           (out-of-source? #f)
-                          (tests? #t)
+                          (tests? #f)             ; nothing can be done
                           (test-target "check")
                           (parallel-build? #t) (parallel-tests? #t)
                           (patch-shebangs? #t)
@@ -340,14 +364,12 @@ inputs."
                           (strip-flags ''("--strip-debug"))
                           (strip-directories ''("lib" "lib64" "libexec"
                                                 "bin" "sbin"))
-                          (phases '%standard-cross-phases)
+                          (phases '%standard-phases)
                           (system (%current-system))
-                          (implicit-inputs? #t)    ; useful when bootstrapping
+                          (implicit-inputs? #t)
                           (imported-modules '((guix build gnu-build-system)
-                                              (guix build gnu-cross-build)
                                               (guix build utils)))
                           (modules '((guix build gnu-build-system)
-                                     (guix build gnu-cross-build)
                                      (guix build utils))))
   "Cross-build NAME for TARGET, where TARGET is a GNU triplet.  INPUTS are
 cross-built inputs, and NATIVE-INPUTS are inputs that run on the build
@@ -450,7 +472,9 @@ platform."
                                   ,@(if implicit-inputs?
                                         implicit-host-inputs
                                         '()))
-                                #:outputs outputs
+                                #:outputs (if strip-binaries?
+                                              outputs
+                                              (delete "debug" outputs))
                                 #:modules imported-modules
                                 #:guile-for-build guile-for-build))
 
diff --git a/guix/build-system/trivial.scm b/guix/build-system/trivial.scm
index 85a3c697e3..3c5031c4bd 100644
--- a/guix/build-system/trivial.scm
+++ b/guix/build-system/trivial.scm
@@ -53,8 +53,7 @@ ignored."
                               outputs guile system builder (modules '())
                               search-paths native-search-paths)
   "Like `trivial-build', but in a cross-compilation context."
-  (build-expression->derivation store name system
-                                `(let ((%target ,target)) ,builder)
+  (build-expression->derivation store name system builder
                                 (append native-inputs inputs)
                                 #:outputs outputs
                                 #:modules modules
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 47820aa02e..ebcb185e13 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -48,15 +48,28 @@
                     #f
                     dir))
 
-(define* (set-paths #:key inputs (search-paths '())
+(define* (set-paths #:key target inputs native-inputs
+                    (search-paths '()) (native-search-paths '())
                     #:allow-other-keys)
   (define input-directories
     (match inputs
       (((_ . dir) ...)
        dir)))
 
+  (define native-input-directories
+    (match native-inputs
+      (((_ . dir) ...)
+       dir)
+      (#f                                         ; not cross compiling
+       '())))
+
+  ;; When cross building, $PATH must refer only to native (host) inputs since
+  ;; target inputs are not executable.
   (set-path-environment-variable "PATH" '("bin" "sbin")
-                                 input-directories)
+                                 (append native-input-directories
+                                         (if target
+                                             '()
+                                             input-directories)))
 
   (for-each (match-lambda
              ((env-var (directories ...) separator)
@@ -65,8 +78,16 @@
                                              #:separator separator)))
             search-paths)
 
-  ;; Dump the environment variables as a shell script, for handy debugging.
-  (system "export > environment-variables"))
+  (when native-search-paths
+    ;; Search paths for native inputs, when cross building.
+    (for-each (match-lambda
+               ((env-var (directories ...) separator)
+                (set-path-environment-variable env-var directories
+                                               native-input-directories
+                                               #:separator separator)))
+              native-search-paths))
+
+  #t)
 
 (define* (unpack #:key source #:allow-other-keys)
   (and (zero? (system* "tar" "xvf" source))
@@ -102,7 +123,8 @@ makefiles."
                          (append patch-flags (list "--input" p)))))
          patches))
 
-(define* (configure #:key inputs outputs (configure-flags '()) out-of-source?
+(define* (configure #:key target native-inputs inputs outputs
+                    (configure-flags '()) out-of-source?
                     #:allow-other-keys)
   (define (package-name)
     (let* ((out  (assoc-ref outputs "out"))
@@ -119,7 +141,7 @@ makefiles."
          (libdir     (assoc-ref outputs "lib"))
          (includedir (assoc-ref outputs "include"))
          (docdir     (assoc-ref outputs "doc"))
-         (bash       (or (and=> (assoc-ref inputs "bash")
+         (bash       (or (and=> (assoc-ref (or native-inputs inputs) "bash")
                                 (cut string-append <> "/bin/bash"))
                          "/bin/sh"))
          (flags      `(,(string-append "CONFIG_SHELL=" bash)
@@ -148,6 +170,9 @@ makefiles."
                              (list (string-append "--docdir=" docdir
                                                   "/doc/" (package-name)))
                              '())
+                       ,@(if target               ; cross building
+                             (list (string-append "--host=" target))
+                             '())
                        ,@configure-flags))
          (abs-srcdir (getcwd))
          (srcdir     (if out-of-source?
@@ -189,8 +214,8 @@ makefiles."
                         '())
                   ,@make-flags))))
 
-(define* (check #:key (make-flags '()) (tests? #t) (test-target "check")
-                (parallel-tests? #t)
+(define* (check #:key target (make-flags '()) (tests? (not target))
+                (test-target "check") (parallel-tests? #t)
                 #:allow-other-keys)
   (if tests?
       (zero? (apply system* "make" test-target
@@ -230,18 +255,70 @@ makefiles."
                 bindirs)))
   #t)
 
-(define* (strip #:key outputs (strip-binaries? #t)
+(define* (strip #:key target outputs (strip-binaries? #t)
+                (strip-command (if target
+                                   (string-append target "-strip")
+                                   "strip"))
+                (objcopy-command (if target
+                                     (string-append target "-objcopy")
+                                     "objcopy"))
                 (strip-flags '("--strip-debug"))
                 (strip-directories '("lib" "lib64" "libexec"
                                      "bin" "sbin"))
                 #:allow-other-keys)
+  (define debug-output
+    ;; If an output is called "debug", then that's where debugging information
+    ;; will be stored instead of being discarded.
+    (assoc-ref outputs "debug"))
+
+  (define debug-file-extension
+    ;; File name extension for debugging information.
+    ".debug")
+
+  (define (debug-file file)
+    ;; Return the name of the debug file for FILE, an absolute file name.
+    ;; Once installed in the user's profile, it is in $PROFILE/lib/debug/FILE,
+    ;; which is where GDB looks for it (info "(gdb) Separate Debug Files").
+    (string-append debug-output "/lib/debug/"
+                   file debug-file-extension))
+
+  (define (make-debug-file file)
+    ;; Create a file in DEBUG-OUTPUT containing the debugging info of FILE.
+    (let ((debug (debug-file file)))
+      (mkdir-p (dirname debug))
+      (copy-file file debug)
+      (and (zero? (system* strip-command "--only-keep-debug" debug))
+           (begin
+             (chmod debug #o400)
+             #t))))
+
+  (define (add-debug-link file)
+    ;; Add a debug link in FILE (info "(binutils) strip").
+
+    ;; `objcopy --add-gnu-debuglink' wants to have the target of the debug
+    ;; link around so it can compute a CRC of that file (see the
+    ;; `bfd_fill_in_gnu_debuglink_section' function.)  No reference to
+    ;; DEBUG-OUTPUT is kept because bfd keeps only the basename of the debug
+    ;; file.
+    (zero? (system* objcopy-command
+                    (string-append "--add-gnu-debuglink="
+                                   (debug-file file))
+                    file)))
+
   (define (strip-dir dir)
-    (format #t "stripping binaries in ~s with flags ~s~%"
-            dir strip-flags)
+    (format #t "stripping binaries in ~s with ~s and flags ~s~%"
+            dir strip-command strip-flags)
+    (when debug-output
+      (format #t "debugging output written to ~s using ~s~%"
+              debug-output objcopy-command))
     (file-system-fold (const #t)
                       (lambda (path stat result)  ; leaf
-                        (zero? (apply system* "strip"
-                                      (append strip-flags (list path)))))
+                        (and (or (not debug-output)
+                                 (make-debug-file path))
+                             (zero? (apply system* strip-command
+                                           (append strip-flags (list path))))
+                             (or (not debug-output)
+                                 (add-debug-link path))))
                       (const #t)                  ; down
                       (const #t)                  ; up
                       (const #t)                  ; skip
@@ -287,10 +364,13 @@ in order.  Return #t if all the PHASES succeeded, #f otherwise."
   (every (match-lambda
           ((name . proc)
            (let ((start (gettimeofday)))
-            (format #t "starting phase `~a'~%" name)
-            (let ((result (apply proc args))
-                  (end    (gettimeofday)))
-              (format #t "phase `~a' ~:[failed~;succeeded~] after ~a seconds~%"
-                      name result (- (car end) (car start)))
-              result))))
+             (format #t "starting phase `~a'~%" name)
+             (let ((result (apply proc args))
+                   (end    (gettimeofday)))
+               (format #t "phase `~a' ~:[failed~;succeeded~] after ~a seconds~%"
+                       name result (- (car end) (car start)))
+
+               ;; 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/gnu-cross-build.scm b/guix/build/gnu-cross-build.scm
deleted file mode 100644
index dab60684ac..0000000000
--- a/guix/build/gnu-cross-build.scm
+++ /dev/null
@@ -1,138 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; 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 gnu-cross-build)
-  #:use-module (guix build utils)
-  #:use-module ((guix build gnu-build-system)
-                #:renamer (symbol-prefix-proc 'build:))
-  #:use-module (ice-9 ftw)
-  #:use-module (ice-9 match)
-  #:use-module (srfi srfi-1)
-  #:export (%standard-cross-phases
-            gnu-cross-build))
-
-;;; Commentary:
-;;;
-;;; Extension of `gnu-build-system.scm' to support cross-compilation.
-;;;
-;;; Code:
-
-(define* (set-paths #:key inputs native-inputs
-                    (search-paths '()) (native-search-paths '())
-                    #:allow-other-keys)
-  (define input-directories
-    (match inputs
-      (((_ . dir) ...)
-       dir)))
-
-  (define native-input-directories
-    (match native-inputs
-      (((_ . dir) ...)
-       dir)))
-
-  ;; $PATH must refer only to native (host) inputs since target inputs are not
-  ;; executable.
-  (set-path-environment-variable "PATH" '("bin" "sbin")
-                                 native-input-directories)
-
-  ;; Search paths for target inputs.
-  (for-each (match-lambda
-             ((env-var (directories ...) separator)
-              (set-path-environment-variable env-var directories
-                                             input-directories
-                                             #:separator separator)))
-            search-paths)
-
-  ;; Search paths for native inputs.
-  (for-each (match-lambda
-             ((env-var (directories ...) separator)
-              (set-path-environment-variable env-var directories
-                                             native-input-directories
-                                             #:separator separator)))
-            native-search-paths)
-
-  ;; Dump the environment variables as a shell script, for handy debugging.
-  (system "export > environment-variables"))
-
-(define* (configure #:key
-                    inputs outputs (configure-flags '()) out-of-source?
-                    target native-inputs
-                    #:allow-other-keys)
-  (format #t "configuring for cross-compilation to `~a'~%" target)
-  (apply (assoc-ref build:%standard-phases 'configure)
-         #:configure-flags (cons (string-append "--host=" target)
-                                 configure-flags)
-
-         ;; XXX: The underlying `configure' phase looks for Bash among
-         ;; #:inputs, so fool it this way.
-         #:inputs native-inputs
-
-         #:outputs outputs
-         #:out-of-source? out-of-source?
-         '()))
-
-(define* (strip #:key target outputs (strip-binaries? #t)
-                (strip-flags '("--strip-debug"))
-                (strip-directories '("lib" "lib64" "libexec"
-                                     "bin" "sbin"))
-                #:allow-other-keys)
-  ;; TODO: The only difference with `strip' in gnu-build-system.scm is the
-  ;; name of the strip command; factorize it.
-
-  (define (strip-dir dir)
-    (format #t "stripping binaries in ~s with flags ~s~%"
-            dir strip-flags)
-    (file-system-fold (const #t)
-                      (lambda (path stat result)  ; leaf
-                        (zero? (apply system*
-                                      (string-append target "-strip")
-                                      (append strip-flags (list path)))))
-                      (const #t)                  ; down
-                      (const #t)                  ; up
-                      (const #t)                  ; skip
-                      (lambda (path stat errno result)
-                        (format (current-error-port)
-                                "strip: failed to access `~a': ~a~%"
-                                path (strerror errno))
-                        #f)
-                      #t
-                      dir))
-
-  (or (not strip-binaries?)
-      (every strip-dir
-             (append-map (match-lambda
-                          ((_ . dir)
-                           (filter-map (lambda (d)
-                                         (let ((sub (string-append dir "/" d)))
-                                           (and (directory-exists? sub) sub)))
-                                       strip-directories)))
-                         outputs))))
-
-(define %standard-cross-phases
-  ;; The standard phases when cross-building.
-  (let ((replacements `((set-paths ,set-paths)
-                        (configure ,configure)
-                        (strip ,strip))))
-    (fold (lambda (replacement phases)
-            (match replacement
-              ((name proc)
-               (alist-replace name proc phases))))
-          (alist-delete 'check build:%standard-phases)
-          replacements)))
-
-;;; gnu-cross-build.scm ends here
diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index a4a82a5f8c..06e88b1ff8 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -27,6 +27,8 @@
   #:use-module (ice-9 rdelim)
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
+  #:re-export (alist-cons
+               alist-delete)
   #:export (directory-exists?
             executable-file?
             call-with-ascii-input-file
@@ -248,9 +250,17 @@ SEPARATOR-separated path accordingly.  Example:
 "
   (let* ((path  (search-path-as-list sub-directories input-dirs))
          (value (list->search-path-as-string path separator)))
-   (setenv env-var value)
-   (format #t "environment variable `~a' set to `~a'~%"
-           env-var value)))
+    (if (string-null? value)
+        (begin
+          ;; Never set ENV-VAR to an empty string because often, the empty
+          ;; string is equivalent to ".".  This is the case for
+          ;; GUILE_LOAD_PATH in Guile 2.0, for instance.
+          (unsetenv env-var)
+          (format #t "environment variable `~a' unset~%" env-var))
+        (begin
+          (setenv env-var value)
+          (format #t "environment variable `~a' set to `~a'~%"
+                  env-var value)))))
 
 (define (which program)
   "Return the complete file name for PROGRAM as found in $PATH, or #f if