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
 386       ;; Only one output.
 387       (outputs '("out")))))
 388
 389 (define %gcc-static
 390   ;; A statically-linked GCC, with stripped-down functionality.
 391   (package-with-relocatable-glibc
 392    (package (inherit gcc)
 393      (name "gcc-static")
 394      (outputs '("out"))                           ; all in one
 395      (arguments
 396       `(#:modules ((guix build utils)
 397                    (guix build gnu-build-system)
 398                    (srfi srfi-1)
 399                    (srfi srfi-26)
 400                    (ice-9 regex))
 401         ,@(substitute-keyword-arguments (package-arguments gcc)
 402             ((#:guile _) #f)
 403             ((#:implicit-inputs? _) #t)
 404             ((#:configure-flags flags)
 405              `(append (list
 406                        ;; We don't need a full bootstrap here.
 407                        "--disable-bootstrap"
 408
 409                        ;; Make sure '-static' is passed where it matters.
 410                        "--with-stage1-ldflags=-static"
 411
 412                        ;; GCC 4.8+ requires a C++ compiler and library.
 413                        "--enable-languages=c,c++"
 414
 415                        ;; Make sure gcc-nm doesn't require liblto_plugin.so.
 416                        "--disable-lto"
 417
 418                        "--disable-shared"
 419                        "--disable-plugin"
 420                        "--disable-libmudflap"
 421                        "--disable-libatomic"
 422                        "--disable-libsanitizer"
 423                        "--disable-libitm"
 424                        "--disable-libgomp"
 425                        "--disable-libcilkrts"
 426                        "--disable-libvtv"
 427                        "--disable-libssp"
 428                        "--disable-libquadmath")
 429                       (remove (cut string-match "--(.*plugin|enable-languages)" <>)
 430                               ,flags)))
 431             ((#:phases phases)
 432              `(modify-phases ,phases
 433                 (add-after 'pre-configure 'remove-lgcc_s
 434                   (lambda _
 435                     ;; Remove the '-lgcc_s' added to GNU_USER_TARGET_LIB_SPEC in
 436                     ;; the 'pre-configure phase of our main gcc package, because
 437                     ;; that shared library is not present in this static gcc.  See
 438                     ;; <https://lists.gnu.org/archive/html/guix-devel/2015-01/msg00008.html>.
 439                     (substitute* (cons "gcc/config/rs6000/sysv4.h"
 440                                        (find-files "gcc/config"
 441                                                    "^gnu-user.*\\.h$"))
 442                       ((" -lgcc_s}}") "}}"))
 443                     #t)))))))
 444      (inputs
 445       `(("zlib:static" ,zlib "static")
 446         ,@(package-inputs gcc)))
 447      (native-inputs
 448       (if (%current-target-system)
 449           `(;; When doing a Canadian cross, we need GMP/MPFR/MPC both
 450             ;; as target inputs and as native inputs; the latter is
 451             ;; needed when building build-time tools ('genconstants',
 452             ;; etc.)  Failing to do that leads to misdetections of
 453             ;; declarations by 'gcc/configure', and eventually to
 454             ;; duplicate declarations as reported in
 455             ;; <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=59217>.
 456             ("gmp-native" ,gmp)
 457             ("mpfr-native" ,mpfr)
 458             ("mpc-native" ,mpc)
 459             ,@(package-native-inputs gcc))
 460           (package-native-inputs gcc))))))
 461
 462 (define %gcc-stripped
 463   ;; The subset of GCC files needed for bootstrap.
 464   (package (inherit gcc)
 465     (name "gcc-stripped")
 466     (build-system trivial-build-system)
 467     (source #f)
 468     (outputs '("out"))                            ;only one output
 469     (arguments
 470      `(#:modules ((guix build utils))
 471        #:builder
 472        (begin
 473          (use-modules (srfi srfi-1)
 474                       (srfi srfi-26)
 475                       (guix build utils))
 476
 477          (setvbuf (current-output-port) _IOLBF)
 478          (let* ((out        (assoc-ref %outputs "out"))
 479                 (bindir     (string-append out "/bin"))
 480                 (libdir     (string-append out "/lib"))
 481                 (includedir (string-append out "/include"))
 482                 (libexecdir (string-append out "/libexec"))
 483                 (gcc        (assoc-ref %build-inputs "gcc")))
 484            (copy-recursively (string-append gcc "/bin") bindir)
 485            (for-each remove-store-references
 486                      (find-files bindir ".*"))
 487
 488            (copy-recursively (string-append gcc "/lib") libdir)
 489            (for-each remove-store-references
 490                      (remove (cut string-suffix? ".h" <>)
 491                              (find-files libdir ".*")))
 492
 493            (copy-recursively (string-append gcc "/libexec")
 494                              libexecdir)
 495            (for-each remove-store-references
 496                      (find-files libexecdir ".*"))
 497
 498            ;; Starting from GCC 4.8, helper programs built natively
 499            ;; (‘genchecksum’, ‘gcc-nm’, etc.) rely on C++ headers.
 500            (copy-recursively (string-append gcc "/include/c++")
 501                              (string-append includedir "/c++"))
 502
 503            ;; For native builds, check whether the binaries actually work.
 504            ,@(if (%current-target-system)
 505                  '()
 506                  '((for-each (lambda (prog)
 507                                (invoke (string-append gcc "/bin/" prog)
 508                                        "--version"))
 509                              '("gcc" "g++" "cpp"))))
 510
 511            #t))))
 512     (inputs `(("gcc" ,%gcc-static)))))
 513
 514 (define %guile-static
 515   ;; A statically-linked Guile that is relocatable--i.e., it can search
 516   ;; .scm and .go files relative to its installation directory, rather
 517   ;; than in hard-coded configure-time paths.
 518   (let* ((patches (cons* (search-patch "guile-relocatable.patch")
 519                          (search-patch "guile-2.2-default-utf8.patch")
 520                          (search-patch "guile-linux-syscalls.patch")
 521                          (origin-patches (package-source guile-2.2))))
 522          (source  (origin (inherit (package-source guile-2.2))
 523                     (patches patches)))
 524          (guile (package (inherit guile-2.2)
 525                   (name (string-append (package-name guile-2.2) "-static"))
 526                   (source source)
 527                   (synopsis "Statically-linked and relocatable Guile")
 528
 529                   ;; Remove the 'debug' output (see above for the reason.)
 530                   (outputs (delete "debug" (package-outputs guile-2.2)))
 531
 532                   (inputs
 533                    `(("libunistring:static" ,libunistring "static")
 534                      ,@(package-inputs guile-2.2)))
 535
 536                   (propagated-inputs
 537                    `(("bdw-gc" ,libgc)
 538                      ,@(alist-delete "bdw-gc"
 539                                      (package-propagated-inputs guile-2.2))))
 540                   (arguments
 541                    (substitute-keyword-arguments (package-arguments guile-2.2)
 542                      ((#:configure-flags flags '())
 543                       ;; When `configure' checks for ltdl availability, it
 544                       ;; doesn't try to link using libtool, and thus fails
 545                       ;; because of a missing -ldl.  Work around that.
 546                       ''("LDFLAGS=-ldl"))
 547                      ((#:phases phases '%standard-phases)
 548                       `(modify-phases ,phases
 549
 550                          ;; Do not record the absolute file name of 'sh' in
 551                          ;; (ice-9 popen).  This makes 'open-pipe' unusable in
 552                          ;; a build chroot ('open-pipe*' is fine) but avoids
 553                          ;; keeping a reference to Bash.
 554                          (delete 'pre-configure)
 555
 556                          (add-before 'configure 'static-guile
 557                            (lambda _
 558                              (substitute* "libguile/Makefile.in"
 559                                ;; Create a statically-linked `guile'
 560                                ;; executable.
 561                                (("^guile_LDFLAGS =")
 562                                 "guile_LDFLAGS = -all-static")
 563
 564                                ;; Add `-ldl' *after* libguile-2.2.la.
 565                                (("^guile_LDADD =(.*)$" _ ldadd)
 566                                 (string-append "guile_LDADD = "
 567                                                (string-trim-right ldadd)
 568                                                " -ldl\n")))))))
 569                      ((#:tests? _ #f)
 570                       ;; There are uses of `dynamic-link' in
 571                       ;; {foreign,coverage}.test that don't fly here.
 572                       #f))))))
 573     (package-with-relocatable-glibc (static-package guile))))
 574
 575 (define %guile-static-stripped
 576   ;; A stripped static Guile binary, for use during bootstrap.
 577   (package (inherit %guile-static)
 578     (name "guile-static-stripped")
 579     (build-system trivial-build-system)
 580     (arguments
 581      ;; The end result should depend on nothing but itself.
 582      `(#:allowed-references ("out")
 583        #:modules ((guix build utils))
 584        #:builder
 585        (let ()
 586          (use-modules (guix build utils))
 587
 588          (let* ((in     (assoc-ref %build-inputs "guile"))
 589                 (out    (assoc-ref %outputs "out"))
 590                 (guile1 (string-append in "/bin/guile"))
 591                 (guile2 (string-append out "/bin/guile")))
 592            (mkdir-p (string-append out "/share/guile/2.2"))
 593            (copy-recursively (string-append in "/share/guile/2.2")
 594                              (string-append out "/share/guile/2.2"))
 595
 596            (mkdir-p (string-append out "/lib/guile/2.2/ccache"))
 597            (copy-recursively (string-append in "/lib/guile/2.2/ccache")
 598                              (string-append out "/lib/guile/2.2/ccache"))
 599
 600            (mkdir (string-append out "/bin"))
 601            (copy-file guile1 guile2)
 602
 603            ;; Verify that the relocated Guile works.
 604            ,@(if (%current-target-system)
 605                  '()
 606                  '((invoke guile2 "--version")))
 607
 608            ;; Strip store references.
 609            (remove-store-references guile2)
 610
 611            ;; Verify that the stripped Guile works.  If it aborts, it could be
 612            ;; that it tries to open iconv descriptors and fails because libc's
 613            ;; iconv data isn't available (see `guile-default-utf8.patch'.)
 614            ,@(if (%current-target-system)
 615                  '()
 616                  '((invoke guile2 "--version")))
 617
 618            #t))))
 619     (inputs `(("guile" ,%guile-static)))
 620     (outputs '("out"))
 621     (synopsis "Minimal statically-linked and relocatable Guile")))
 622
 623 (define (tarball-package pkg)
 624   "Return a package containing a tarball of PKG."
 625   (package (inherit pkg)
 626     (name (string-append (package-name pkg) "-tarball"))
 627     (build-system trivial-build-system)
 628     (native-inputs `(("tar" ,tar)
 629                      ("xz" ,xz)))
 630     (inputs `(("input" ,pkg)))
 631     (arguments
 632      (let ((name    (package-name pkg))
 633            (version (package-version pkg)))
 634        `(#:modules ((guix build utils))
 635          #:builder
 636          (begin
 637            (use-modules (guix build utils))
 638            (let ((out   (assoc-ref %outputs "out"))
 639                  (input (assoc-ref %build-inputs "input"))
 640                  (tar   (assoc-ref %build-inputs "tar"))
 641                  (xz    (assoc-ref %build-inputs "xz")))
 642              (mkdir out)
 643              (set-path-environment-variable "PATH" '("bin") (list tar xz))
 644              (with-directory-excursion input
 645                (invoke "tar" "cJvf"
 646                        (string-append out "/"
 647                                       ,name "-" ,version
 648                                       "-"
 649                                       ,(or (%current-target-system)
 650                                            (%current-system))
 651                                       ".tar.xz")
 652                        "."
 653                        ;; avoid non-determinism in the archive
 654                        "--sort=name" "--mtime=@0"
 655                        "--owner=root:0" "--group=root:0")))))))))
 656
 657 (define %bootstrap-binaries-tarball
 658   ;; A tarball with the statically-linked bootstrap binaries.
 659   (tarball-package %static-binaries))
 660
 661 (define %binutils-bootstrap-tarball
 662   ;; A tarball with the statically-linked Binutils programs.
 663   (tarball-package %binutils-static-stripped))
 664
 665 (define (%glibc-bootstrap-tarball)
 666   ;; A tarball with GNU libc's shared libraries, dynamic linker, and headers.
 667   (tarball-package (%glibc-stripped)))
 668
 669 (define %gcc-bootstrap-tarball
 670   ;; A tarball with a dynamic-linked GCC and its headers.
 671   (tarball-package %gcc-stripped))
 672
 673 (define %guile-bootstrap-tarball
 674   ;; A tarball with the statically-linked, relocatable Guile.
 675   (tarball-package %guile-static-stripped))
 676
 677 (define %bootstrap-tarballs
 678   ;; A single derivation containing all the bootstrap tarballs, for
 679   ;; convenience.
 680   (package
 681     (name "bootstrap-tarballs")
 682     (version "0")
 683     (source #f)
 684     (build-system trivial-build-system)
 685     (arguments
 686      `(#:modules ((guix build utils))
 687        #:builder
 688        (let ((out (assoc-ref %outputs "out")))
 689          (use-modules (guix build utils)
 690                       (ice-9 match)
 691                       (srfi srfi-26))
 692
 693          (setvbuf (current-output-port) _IOLBF)
 694          (mkdir out)
 695          (chdir out)
 696          (for-each (match-lambda
 697                     ((name . directory)
 698                      (for-each (lambda (file)
 699                                  (format #t "~a -> ~a~%" file out)
 700                                  (symlink file (basename file)))
 701                                (find-files directory "\\.tar\\."))))
 702                    %build-inputs)
 703          #t)))
 704     (inputs `(("guile-tarball" ,%guile-bootstrap-tarball)
 705               ("gcc-tarball" ,%gcc-bootstrap-tarball)
 706               ("binutils-tarball" ,%binutils-bootstrap-tarball)
 707               ("glibc-tarball" ,(%glibc-bootstrap-tarball))
 708               ("coreutils&co-tarball" ,%bootstrap-binaries-tarball)))
 709     (synopsis "Tarballs containing all the bootstrap binaries")
 710     (description synopsis)
 711     (home-page #f)
 712     (license gpl3+)))
 713
 714 ;;; make-bootstrap.scm ends here