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