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