gnu/packages/make-bootstrap.scm

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