gnu/packages/make-bootstrap.scm

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