gnu/packages/make-bootstrap.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
   4 ;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
   5 ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
   6 ;;;
   7 ;;; This file is part of GNU Guix.
   8 ;;;
   9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  10 ;;; under the terms of the GNU General Public License as published by
  11 ;;; the Free Software Foundation; either version 3 of the License, or (at
  12 ;;; your option) any later version.
  13 ;;;
  14 ;;; GNU Guix is distributed in the hope that it will be useful, but
  15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU General Public License
  20 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 (define-module (gnu packages make-bootstrap)
  23   #:use-module (guix utils)
  24   #:use-module (guix packages)
  25   #:use-module ((guix licenses) #:select (gpl3+))
  26   #:use-module (guix build-system trivial)
  27   #:use-module (guix build-system gnu)
  28   #:use-module ((gnu packages) #:select (search-patch))
  29   #:use-module (gnu packages base)
  30   #:use-module (gnu packages cross-base)
  31   #:use-module (gnu packages bash)
  32   #:use-module (gnu packages compression)
  33   #:use-module (gnu packages gawk)
  34   #:use-module (gnu packages gcc)
  35   #:use-module (gnu packages guile)
  36   #:use-module (gnu packages bdw-gc)
  37   #:use-module (gnu packages libunistring)
  38   #:use-module (gnu packages linux)
  39   #:use-module (gnu packages hurd)
  40   #:use-module (gnu packages multiprecision)
  41   #:use-module (ice-9 match)
  42   #:use-module (srfi srfi-1)
  43   #:export (%bootstrap-binaries-tarball
  44             %binutils-bootstrap-tarball
  45             %glibc-bootstrap-tarball
  46             %gcc-bootstrap-tarball
  47             %guile-bootstrap-tarball
  48             %bootstrap-tarballs
  49
  50             %guile-static-stripped))
  51
  52 ;;; Commentary:
  53 ;;;
  54 ;;; This module provides tools to build tarballs of the "bootstrap binaries"
  55 ;;; used in (gnu packages bootstrap).  These statically-linked binaries are
  56 ;;; taken for granted and used as the root of the whole bootstrap procedure.
  57 ;;;
  58 ;;; Code:
  59
  60 (define* (glibc-for-bootstrap #:optional (base glibc))
  61   "Return a libc deriving from BASE whose `system' and `popen' functions looks
  62 for `sh' in $PATH, and without nscd, and with static NSS modules."
  63   (package (inherit base)
  64     (source (origin (inherit (package-source base))
  65               (patches (cons (search-patch "glibc-bootstrap-system.patch")
  66                              (origin-patches (package-source base))))))
  67     (arguments
  68      (substitute-keyword-arguments (package-arguments base)
  69        ((#:configure-flags flags)
  70         ;; Arrange so that getaddrinfo & co. do not contact the nscd,
  71         ;; and can use statically-linked NSS modules.
  72         `(cons* "--disable-nscd" "--disable-build-nscd"
  73                 "--enable-static-nss"
  74                 ,flags))))
  75
  76     ;; Remove the 'debug' output to allow bit-reproducible builds (when the
  77     ;; 'debug' output is used, ELF files end up with a .gnu_debuglink, which
  78     ;; includes a CRC of the corresponding debugging symbols; those symbols
  79     ;; contain store file names, so the CRC changes at every rebuild.)
  80     (outputs (delete "debug" (package-outputs base)))))
  81
  82 (define (package-with-relocatable-glibc p)
  83   "Return a variant of P that uses the libc as defined by
  84 `glibc-for-bootstrap'."
  85
  86   (define (cross-bootstrap-libc)
  87     (let ((target (%current-target-system)))
  88       (glibc-for-bootstrap
  89        ;; `cross-libc' already returns a cross libc, so clear
  90        ;; %CURRENT-TARGET-SYSTEM.
  91        (parameterize ((%current-target-system #f))
  92          (cross-libc target)))))
  93
  94   ;; Standard inputs with the above libc and corresponding GCC.
  95
  96   (define (inputs)
  97     (if (%current-target-system)                ; is this package cross built?
  98         `(("cross-libc" ,(cross-bootstrap-libc)))
  99         '()))
 100
 101   (define (native-inputs)
 102     (if (%current-target-system)
 103         (let ((target (%current-target-system)))
 104           `(("cross-gcc"      ,(cross-gcc target
 105                                           #:xbinutils (cross-binutils target)
 106                                           #:libc (cross-bootstrap-libc)))
 107             ("cross-binutils" ,(cross-binutils target))
 108             ,@(%final-inputs)))
 109         `(("libc" ,(glibc-for-bootstrap))
 110           ("libc:static" ,(glibc-for-bootstrap) "static")
 111           ("gcc" ,(package (inherit gcc)
 112                     (outputs '("out")) ; all in one so libgcc_s is easily found
 113                     (inputs
 114                      `(("libc" ,(glibc-for-bootstrap))
 115                        ("libc:static" ,(glibc-for-bootstrap) "static")
 116                        ,@(package-inputs gcc)))))
 117           ,@(fold alist-delete (%final-inputs) '("libc" "gcc")))))
 118
 119   (package-with-explicit-inputs p inputs
 120                                 (current-source-location)
 121                                 #:native-inputs native-inputs))
 122
 123 (define %static-inputs
 124   ;; Packages that are to be used as %BOOTSTRAP-INPUTS.
 125   (let ((coreutils (package (inherit coreutils)
 126                       (arguments
 127                        `(#:configure-flags
 128                          '("--disable-nls"
 129                            "--disable-silent-rules"
 130                            "--enable-no-install-program=stdbuf,libstdbuf.so"
 131                            "CFLAGS=-Os -g0"        ; smaller, please
 132                            "LDFLAGS=-static -pthread")
 133                          #:tests? #f   ; signal-related Gnulib tests fail
 134                          ,@(package-arguments coreutils)))
 135
 136                       ;; Remove optional dependencies such as GMP.  Keep Perl
 137                       ;; except if it's missing (which is the case when
 138                       ;; cross-compiling).
 139                       (inputs (match (assoc "perl" (package-inputs coreutils))
 140                                 (#f '())
 141                                 (x  (list x))))
 142
 143                       ;; Remove the 'debug' output (see above for the reason.)
 144                       (outputs '("out"))))
 145         (bzip2 (package (inherit bzip2)
 146                  (arguments
 147                   (substitute-keyword-arguments (package-arguments bzip2)
 148                     ((#:phases phases)
 149                      `(modify-phases ,phases
 150                         (add-before 'build 'dash-static
 151                           (lambda _
 152                             (substitute* "Makefile"
 153                               (("^LDFLAGS[[:blank:]]*=.*$")
 154                                "LDFLAGS = -static"))
 155                             #t))))))))
 156         (xz (package (inherit xz)
 157               (arguments
 158                `(#:strip-flags '("--strip-all")
 159                  #:phases (modify-phases %standard-phases
 160                             (add-before 'configure 'static-executable
 161                               (lambda _
 162                                 ;; Ask Libtool for a static executable.
 163                                 (substitute* "src/xz/Makefile.in"
 164                                   (("^xz_LDADD =")
 165                                    "xz_LDADD = -all-static"))
 166                                 #t)))))))
 167         (gawk (package (inherit gawk)
 168                 (source (origin (inherit (package-source gawk))
 169                           (patches (cons (search-patch "gawk-shell.patch")
 170                                          (origin-patches
 171                                           (package-source gawk))))))
 172                 (arguments
 173                  `(;; Starting from gawk 4.1.0, some of the tests for the
 174                    ;; plug-in mechanism just fail on static builds:
 175                    ;;
 176                    ;; ./fts.awk:1: error: can't open shared library `filefuncs' for reading (No such file or directory)
 177                    #:tests? #f
 178
 179                    ,@(substitute-keyword-arguments (package-arguments gawk)
 180                        ((#:phases phases)
 181                         `(modify-phases ,phases
 182                            (add-before 'configure 'no-export-dynamic
 183                              (lambda _
 184                                ;; Since we use `-static', remove
 185                                ;; `-export-dynamic'.
 186                                (substitute* "configure"
 187                                  (("-Wl,-export-dynamic") ""))
 188                                #t)))))))
 189                 (inputs (if (%current-target-system)
 190                             `(("bash" ,static-bash))
 191                             '()))))
 192         (tar (package (inherit tar)
 193                (arguments
 194                 (substitute-keyword-arguments (package-arguments tar)
 195                   ((#:phases phases)
 196                    `(modify-phases ,phases
 197                       (replace 'set-shell-file-name
 198                         (lambda _
 199                           ;; Do not use "/bin/sh" to run programs; see
 200                           ;; <http://lists.gnu.org/archive/html/guix-devel/2016-09/msg02272.html>.
 201                           (substitute* "src/system.c"
 202                             (("/bin/sh") "sh")
 203                             (("execv ") "execvp "))
 204                           #t))))))))
 205         ;; We don't want to retain a reference to /gnu/store in the bootstrap
 206         ;; versions of egrep/fgrep, so we remove the custom phase added since
 207         ;; grep@2.25. The effect is 'egrep' and 'fgrep' look for 'grep' in
 208         ;; $PATH.
 209         (grep (package
 210                 (inherit grep)
 211                 (inputs '())                   ;remove PCRE, which is optional
 212                 (arguments
 213                  (substitute-keyword-arguments (package-arguments grep)
 214                    ((#:phases phases)
 215                     `(modify-phases ,phases
 216                        (delete 'fix-egrep-and-fgrep)))))))
 217         (finalize (compose static-package
 218                            package-with-relocatable-glibc)))
 219     `(,@(map (match-lambda
 220               ((name package)
 221                (list name (finalize package))))
 222              `(("tar" ,tar)
 223                ("gzip" ,gzip)
 224                ("bzip2" ,bzip2)
 225                ("xz" ,xz)
 226                ("patch" ,patch)
 227                ("coreutils" ,coreutils)
 228                ("sed" ,sed)
 229                ("grep" ,grep)
 230                ("gawk" ,gawk)))
 231       ("bash" ,static-bash))))
 232
 233 (define %static-binaries
 234   (package
 235     (name "static-binaries")
 236     (version "0")
 237     (build-system trivial-build-system)
 238     (source #f)
 239     (inputs %static-inputs)
 240     (arguments
 241      `(#:modules ((guix build utils))
 242        #:builder
 243        (begin
 244          (use-modules (ice-9 ftw)
 245                       (ice-9 match)
 246                       (srfi srfi-1)
 247                       (srfi srfi-26)
 248                       (guix build utils))
 249
 250          (let ()
 251           (define (directory-contents dir)
 252             (map (cut string-append dir "/" <>)
 253                  (scandir dir (negate (cut member <> '("." ".."))))))
 254
 255           (define (copy-directory source destination)
 256             (for-each (lambda (file)
 257                         (format #t "copying ~s...~%" file)
 258                         (copy-file file
 259                                    (string-append destination "/"
 260                                                   (basename file))))
 261                       (directory-contents source)))
 262
 263           (let* ((out (assoc-ref %outputs "out"))
 264                  (bin (string-append out "/bin")))
 265             (mkdir-p bin)
 266
 267             ;; Copy Coreutils binaries.
 268             (let* ((coreutils (assoc-ref %build-inputs "coreutils"))
 269                    (source    (string-append coreutils "/bin")))
 270               (copy-directory source bin))
 271
 272             ;; For the other inputs, copy just one binary, which has the
 273             ;; same name as the input.
 274             (for-each (match-lambda
 275                        ((name . dir)
 276                         (let ((source (string-append dir "/bin/" name)))
 277                           (format #t "copying ~s...~%" source)
 278                           (copy-file source
 279                                      (string-append bin "/" name)))))
 280                       (alist-delete "coreutils" %build-inputs))
 281
 282             ;; But of course, there are exceptions to this rule.
 283             (let ((grep (assoc-ref %build-inputs "grep")))
 284               (install-file (string-append grep "/bin/fgrep") bin)
 285               (install-file (string-append grep "/bin/egrep") bin))
 286
 287             ;; Clear references to the store path.
 288             (for-each remove-store-references
 289                       (directory-contents bin))
 290
 291             (with-directory-excursion bin
 292               ;; Programs such as Perl's build system want these aliases.
 293               (symlink "bash" "sh")
 294               (symlink "gawk" "awk"))
 295
 296             #t)))))
 297     (synopsis "Statically-linked bootstrap binaries")
 298     (description
 299      "Binaries used to bootstrap the distribution.")
 300     (license gpl3+)
 301     (home-page #f)))
 302
 303 (define %binutils-static
 304   ;; Statically-linked Binutils.
 305   (package (inherit binutils)
 306     (name "binutils-static")
 307     (arguments
 308      `(#:configure-flags (cons "--disable-gold"
 309                                ,(match (memq #:configure-flags
 310                                              (package-arguments binutils))
 311                                   ((#:configure-flags flags _ ...)
 312                                    flags)))
 313        #:strip-flags '("--strip-all")
 314        #:phases (modify-phases %standard-phases
 315                   (add-before 'configure 'all-static
 316                     (lambda _
 317                       ;; The `-all-static' libtool flag can only be passed
 318                       ;; after `configure', since configure tests don't use
 319                       ;; libtool, and only for executables built with libtool.
 320                       (substitute* '("binutils/Makefile.in"
 321                                      "gas/Makefile.in"
 322                                      "ld/Makefile.in")
 323                         (("^LDFLAGS =(.*)$" line)
 324                          (string-append line
 325                                         "\nAM_LDFLAGS = -static -all-static\n")))
 326                       #t)))))))
 327
 328 (define %binutils-static-stripped
 329   ;; The subset of Binutils that we need.
 330   (package (inherit %binutils-static)
 331     (name (string-append (package-name %binutils-static) "-stripped"))
 332     (build-system trivial-build-system)
 333     (outputs '("out"))
 334     (arguments
 335      `(#:modules ((guix build utils))
 336        #:builder
 337        (begin
 338          (use-modules (guix build utils))
 339
 340          (setvbuf (current-output-port) _IOLBF)
 341          (let* ((in  (assoc-ref %build-inputs "binutils"))
 342                 (out (assoc-ref %outputs "out"))
 343                 (bin (string-append out "/bin")))
 344            (mkdir-p bin)
 345            (for-each (lambda (file)
 346                        (let ((target (string-append bin "/" file)))
 347                          (format #t "copying `~a'...~%" file)
 348                          (copy-file (string-append in "/bin/" file)
 349                                     target)
 350                          (remove-store-references target)))
 351                      '("ar" "as" "ld" "nm"  "objcopy" "objdump"
 352                        "ranlib" "readelf" "size" "strings" "strip"))
 353            #t))))
 354     (inputs `(("binutils" ,%binutils-static)))))
 355
 356 (define (%glibc-stripped)
 357   ;; GNU libc's essential shared libraries, dynamic linker, and headers,
 358   ;; with all references to store directories stripped.  As a result,
 359   ;; libc.so is unusable and need to be patched for proper relocation.
 360   (let ((glibc (glibc-for-bootstrap)))
 361     (package (inherit glibc)
 362       (name "glibc-stripped")
 363       (build-system trivial-build-system)
 364       (arguments
 365        `(#:modules ((guix build utils)
 366                     (guix build make-bootstrap))
 367          #:builder
 368          (begin
 369            (use-modules (guix build make-bootstrap))
 370            (make-stripped-libc (assoc-ref %outputs "out")
 371                                (assoc-ref %build-inputs "libc")
 372                                (assoc-ref %build-inputs "kernel-headers")))))
 373       (inputs `(("kernel-headers"
 374                  ,(if (or (and (%current-target-system)
 375                                (hurd-triplet? (%current-target-system)))
 376                           (string-suffix? "-hurd" (%current-system)))
 377                       gnumach-headers
 378                       linux-libre-headers))
 379                 ("libc" ,(let ((target (%current-target-system)))
 380                            (if target
 381                                (glibc-for-bootstrap
 382                                 (parameterize ((%current-target-system #f))
 383                                   (cross-libc target)))
 384                                glibc)))))
 385       (native-inputs '())
 386       (propagated-inputs '())
 387
 388       ;; Only one output.
 389       (outputs '("out")))))
 390
 391 (define %gcc-static
 392   ;; A statically-linked GCC, with stripped-down functionality.
 393   (package-with-relocatable-glibc
 394    (package (inherit gcc)
 395      (name "gcc-static")
 396      (outputs '("out"))                           ; all in one
 397      (arguments
 398       `(#:modules ((guix build utils)
 399                    (guix build gnu-build-system)
 400                    (srfi srfi-1)
 401                    (srfi srfi-26)
 402                    (ice-9 regex))
 403         ,@(substitute-keyword-arguments (package-arguments gcc)
 404             ((#:guile _) #f)
 405             ((#:implicit-inputs? _) #t)
 406             ((#:configure-flags flags)
 407              `(append (list
 408                        ;; We don't need a full bootstrap here.
 409                        "--disable-bootstrap"
 410
 411                        ;; Make sure '-static' is passed where it matters.
 412                        "--with-stage1-ldflags=-static"
 413
 414                        ;; GCC 4.8+ requires a C++ compiler and library.
 415                        "--enable-languages=c,c++"
 416
 417                        ;; Make sure gcc-nm doesn't require liblto_plugin.so.
 418                        "--disable-lto"
 419
 420                        "--disable-shared"
 421                        "--disable-plugin"
 422                        "--disable-libmudflap"
 423                        "--disable-libatomic"
 424                        "--disable-libsanitizer"
 425                        "--disable-libitm"
 426                        "--disable-libgomp"
 427                        "--disable-libcilkrts"
 428                        "--disable-libvtv"
 429                        "--disable-libssp"
 430                        "--disable-libquadmath")
 431                       (remove (cut string-match "--(.*plugin|enable-languages)" <>)
 432                               ,flags)))
 433             ((#:phases phases)
 434              `(modify-phases ,phases
 435                 (add-after 'pre-configure 'remove-lgcc_s
 436                   (lambda _
 437                     ;; Remove the '-lgcc_s' added to GNU_USER_TARGET_LIB_SPEC in
 438                     ;; the 'pre-configure phase of our main gcc package, because
 439                     ;; that shared library is not present in this static gcc.  See
 440                     ;; <https://lists.gnu.org/archive/html/guix-devel/2015-01/msg00008.html>.
 441                     (substitute* (cons "gcc/config/rs6000/sysv4.h"
 442                                        (find-files "gcc/config"
 443                                                    "^gnu-user.*\\.h$"))
 444                       ((" -lgcc_s}}") "}}"))
 445                     #t)))))))
 446      (inputs
 447       `(("zlib:static" ,zlib "static")
 448         ,@(package-inputs gcc)))
 449      (native-inputs
 450       (if (%current-target-system)
 451           `(;; When doing a Canadian cross, we need GMP/MPFR/MPC both
 452             ;; as target inputs and as native inputs; the latter is
 453             ;; needed when building build-time tools ('genconstants',
 454             ;; etc.)  Failing to do that leads to misdetections of
 455             ;; declarations by 'gcc/configure', and eventually to
 456             ;; duplicate declarations as reported in
 457             ;; <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=59217>.
 458             ("gmp-native" ,gmp)
 459             ("mpfr-native" ,mpfr)
 460             ("mpc-native" ,mpc)
 461             ,@(package-native-inputs gcc))
 462           (package-native-inputs gcc))))))
 463
 464 (define %gcc-stripped
 465   ;; The subset of GCC files needed for bootstrap.
 466   (package (inherit gcc)
 467     (name "gcc-stripped")
 468     (build-system trivial-build-system)
 469     (source #f)
 470     (outputs '("out"))                            ;only one output
 471     (arguments
 472      `(#:modules ((guix build utils))
 473        #:builder
 474        (begin
 475          (use-modules (srfi srfi-1)
 476                       (srfi srfi-26)
 477                       (guix build utils))
 478
 479          (setvbuf (current-output-port) _IOLBF)
 480          (let* ((out        (assoc-ref %outputs "out"))
 481                 (bindir     (string-append out "/bin"))
 482                 (libdir     (string-append out "/lib"))
 483                 (includedir (string-append out "/include"))
 484                 (libexecdir (string-append out "/libexec"))
 485                 (gcc        (assoc-ref %build-inputs "gcc")))
 486            (copy-recursively (string-append gcc "/bin") bindir)
 487            (for-each remove-store-references
 488                      (find-files bindir ".*"))
 489
 490            (copy-recursively (string-append gcc "/lib") libdir)
 491            (for-each remove-store-references
 492                      (remove (cut string-suffix? ".h" <>)
 493                              (find-files libdir ".*")))
 494
 495            (copy-recursively (string-append gcc "/libexec")
 496                              libexecdir)
 497            (for-each remove-store-references
 498                      (find-files libexecdir ".*"))
 499
 500            ;; Starting from GCC 4.8, helper programs built natively
 501            ;; (‘genchecksum’, ‘gcc-nm’, etc.) rely on C++ headers.
 502            (copy-recursively (string-append gcc "/include/c++")
 503                              (string-append includedir "/c++"))
 504
 505            ;; For native builds, check whether the binaries actually work.
 506            ,@(if (%current-target-system)
 507                  '()
 508                  '((for-each (lambda (prog)
 509                                (invoke (string-append gcc "/bin/" prog)
 510                                        "--version"))
 511                              '("gcc" "g++" "cpp"))))
 512
 513            #t))))
 514     (inputs `(("gcc" ,%gcc-static)))))
 515
 516 (define %guile-static
 517   ;; A statically-linked Guile that is relocatable--i.e., it can search
 518   ;; .scm and .go files relative to its installation directory, rather
 519   ;; than in hard-coded configure-time paths.
 520   (let* ((patches (cons* (search-patch "guile-relocatable.patch")
 521                          (search-patch "guile-2.2-default-utf8.patch")
 522                          (search-patch "guile-linux-syscalls.patch")
 523                          (origin-patches (package-source guile-2.2))))
 524          (source  (origin (inherit (package-source guile-2.2))
 525                     (patches patches)))
 526          (guile (package (inherit guile-2.2)
 527                   (name (string-append (package-name guile-2.2) "-static"))
 528                   (source source)
 529                   (synopsis "Statically-linked and relocatable Guile")
 530
 531                   ;; Remove the 'debug' output (see above for the reason.)
 532                   (outputs (delete "debug" (package-outputs guile-2.2)))
 533
 534                   (inputs
 535                    `(("libunistring:static" ,libunistring "static")
 536                      ,@(package-inputs guile-2.2)))
 537
 538                   (propagated-inputs
 539                    `(("bdw-gc" ,libgc)
 540                      ,@(alist-delete "bdw-gc"
 541                                      (package-propagated-inputs guile-2.2))))
 542                   (arguments
 543                    (substitute-keyword-arguments (package-arguments guile-2.2)
 544                      ((#:configure-flags flags '())
 545                       ;; When `configure' checks for ltdl availability, it
 546                       ;; doesn't try to link using libtool, and thus fails
 547                       ;; because of a missing -ldl.  Work around that.
 548                       ''("LDFLAGS=-ldl"))
 549                      ((#:phases phases '%standard-phases)
 550                       `(modify-phases ,phases
 551
 552                          ;; Do not record the absolute file name of 'sh' in
 553                          ;; (ice-9 popen).  This makes 'open-pipe' unusable in
 554                          ;; a build chroot ('open-pipe*' is fine) but avoids
 555                          ;; keeping a reference to Bash.
 556                          (delete 'pre-configure)
 557
 558                          (add-before 'configure 'static-guile
 559                            (lambda _
 560                              (substitute* "libguile/Makefile.in"
 561                                ;; Create a statically-linked `guile'
 562                                ;; executable.
 563                                (("^guile_LDFLAGS =")
 564                                 "guile_LDFLAGS = -all-static")
 565
 566                                ;; Add `-ldl' *after* libguile-2.2.la.
 567                                (("^guile_LDADD =(.*)$" _ ldadd)
 568                                 (string-append "guile_LDADD = "
 569                                                (string-trim-right ldadd)
 570                                                " -ldl\n")))))))
 571                      ((#:tests? _ #f)
 572                       ;; There are uses of `dynamic-link' in
 573                       ;; {foreign,coverage}.test that don't fly here.
 574                       #f))))))
 575     (package-with-relocatable-glibc (static-package guile))))
 576
 577 (define %guile-static-stripped
 578   ;; A stripped static Guile binary, for use during bootstrap.
 579   (package (inherit %guile-static)
 580     (name "guile-static-stripped")
 581     (build-system trivial-build-system)
 582     (arguments
 583      ;; The end result should depend on nothing but itself.
 584      `(#:allowed-references ("out")
 585        #:modules ((guix build utils))
 586        #:builder
 587        (let ()
 588          (use-modules (guix build utils))
 589
 590          (let* ((in     (assoc-ref %build-inputs "guile"))
 591                 (out    (assoc-ref %outputs "out"))
 592                 (guile1 (string-append in "/bin/guile"))
 593                 (guile2 (string-append out "/bin/guile")))
 594            (mkdir-p (string-append out "/share/guile/2.2"))
 595            (copy-recursively (string-append in "/share/guile/2.2")
 596                              (string-append out "/share/guile/2.2"))
 597
 598            (mkdir-p (string-append out "/lib/guile/2.2/ccache"))
 599            (copy-recursively (string-append in "/lib/guile/2.2/ccache")
 600                              (string-append out "/lib/guile/2.2/ccache"))
 601
 602            (mkdir (string-append out "/bin"))
 603            (copy-file guile1 guile2)
 604
 605            ;; Verify that the relocated Guile works.
 606            ,@(if (%current-target-system)
 607                  '()
 608                  '((invoke guile2 "--version")))
 609
 610            ;; Strip store references.
 611            (remove-store-references guile2)
 612
 613            ;; Verify that the stripped Guile works.  If it aborts, it could be
 614            ;; that it tries to open iconv descriptors and fails because libc's
 615            ;; iconv data isn't available (see `guile-default-utf8.patch'.)
 616            ,@(if (%current-target-system)
 617                  '()
 618                  '((invoke guile2 "--version")))
 619
 620            #t))))
 621     (inputs `(("guile" ,%guile-static)))
 622     (outputs '("out"))
 623     (synopsis "Minimal statically-linked and relocatable Guile")))
 624
 625 (define (tarball-package pkg)
 626   "Return a package containing a tarball of PKG."
 627   (package (inherit pkg)
 628     (name (string-append (package-name pkg) "-tarball"))
 629     (build-system trivial-build-system)
 630     (native-inputs `(("tar" ,tar)
 631                      ("xz" ,xz)))
 632     (inputs `(("input" ,pkg)))
 633     (arguments
 634      (let ((name    (package-name pkg))
 635            (version (package-version pkg)))
 636        `(#:modules ((guix build utils))
 637          #:builder
 638          (begin
 639            (use-modules (guix build utils))
 640            (let ((out   (assoc-ref %outputs "out"))
 641                  (input (assoc-ref %build-inputs "input"))
 642                  (tar   (assoc-ref %build-inputs "tar"))
 643                  (xz    (assoc-ref %build-inputs "xz")))
 644              (mkdir out)
 645              (set-path-environment-variable "PATH" '("bin") (list tar xz))
 646              (with-directory-excursion input
 647                (invoke "tar" "cJvf"
 648                        (string-append out "/"
 649                                       ,name "-" ,version
 650                                       "-"
 651                                       ,(or (%current-target-system)
 652                                            (%current-system))
 653                                       ".tar.xz")
 654                        "."
 655                        ;; avoid non-determinism in the archive
 656                        "--sort=name" "--mtime=@0"
 657                        "--owner=root:0" "--group=root:0")))))))))
 658
 659 (define %bootstrap-binaries-tarball
 660   ;; A tarball with the statically-linked bootstrap binaries.
 661   (tarball-package %static-binaries))
 662
 663 (define %binutils-bootstrap-tarball
 664   ;; A tarball with the statically-linked Binutils programs.
 665   (tarball-package %binutils-static-stripped))
 666
 667 (define (%glibc-bootstrap-tarball)
 668   ;; A tarball with GNU libc's shared libraries, dynamic linker, and headers.
 669   (tarball-package (%glibc-stripped)))
 670
 671 (define %gcc-bootstrap-tarball
 672   ;; A tarball with a dynamic-linked GCC and its headers.
 673   (tarball-package %gcc-stripped))
 674
 675 (define %guile-bootstrap-tarball
 676   ;; A tarball with the statically-linked, relocatable Guile.
 677   (tarball-package %guile-static-stripped))
 678
 679 (define %bootstrap-tarballs
 680   ;; A single derivation containing all the bootstrap tarballs, for
 681   ;; convenience.
 682   (package
 683     (name "bootstrap-tarballs")
 684     (version "0")
 685     (source #f)
 686     (build-system trivial-build-system)
 687     (arguments
 688      `(#:modules ((guix build utils))
 689        #:builder
 690        (let ((out (assoc-ref %outputs "out")))
 691          (use-modules (guix build utils)
 692                       (ice-9 match)
 693                       (srfi srfi-26))
 694
 695          (setvbuf (current-output-port) _IOLBF)
 696          (mkdir out)
 697          (chdir out)
 698          (for-each (match-lambda
 699                     ((name . directory)
 700                      (for-each (lambda (file)
 701                                  (format #t "~a -> ~a~%" file out)
 702                                  (symlink file (basename file)))
 703                                (find-files directory "\\.tar\\."))))
 704                    %build-inputs)
 705          #t)))
 706     (inputs `(("guile-tarball" ,%guile-bootstrap-tarball)
 707               ("gcc-tarball" ,%gcc-bootstrap-tarball)
 708               ("binutils-tarball" ,%binutils-bootstrap-tarball)
 709               ("glibc-tarball" ,(%glibc-bootstrap-tarball))
 710               ("coreutils&co-tarball" ,%bootstrap-binaries-tarball)))
 711     (synopsis "Tarballs containing all the bootstrap binaries")
 712     (description synopsis)
 713     (home-page #f)
 714     (license gpl3+)))
 715
 716 ;;; make-bootstrap.scm ends here