gnu/packages/make-bootstrap.scm

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