gnu/packages/make-bootstrap.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
   4 ;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
   5 ;;; Copyright © 2018, 2019 Mark H Weaver <mhw@netris.org>
   6 ;;; Copyright © 2018, 2019, 2021 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   7 ;;; Copyright © 2019, 2020 Marius Bakke <mbakke@fastmail.com>
   8 ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
   9 ;;;
  10 ;;; This file is part of GNU Guix.
  11 ;;;
  12 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  13 ;;; under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 3 of the License, or (at
  15 ;;; your option) any later version.
  16 ;;;
  17 ;;; GNU Guix is distributed in the hope that it will be useful, but
  18 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 (define-module (gnu packages make-bootstrap)
  26   #:use-module (guix utils)
  27   #:use-module (guix packages)
  28   #:use-module (guix memoization)
  29   #:use-module ((guix licenses) #:select (gpl3+))
  30   #:use-module (guix build-system trivial)
  31   #:use-module (guix build-system gnu)
  32   #:use-module ((gnu packages) #:select (search-patch))
  33   #:use-module (gnu packages base)
  34   #:use-module (gnu packages cross-base)
  35   #:use-module (gnu packages bash)
  36   #:use-module (gnu packages compression)
  37   #:use-module (gnu packages gawk)
  38   #:use-module (gnu packages gcc)
  39   #:use-module (gnu packages guile)
  40   #:use-module (gnu packages bdw-gc)
  41   #:use-module (gnu packages libunistring)
  42   #:use-module (gnu packages linux)
  43   #:use-module (gnu packages hurd)
  44   #:use-module (gnu packages mes)
  45   #:use-module (gnu packages multiprecision)
  46   #:use-module (ice-9 match)
  47   #:use-module (srfi srfi-1)
  48   #:export (%bootstrap-binaries-tarball
  49             %linux-libre-headers-bootstrap-tarball
  50             %binutils-bootstrap-tarball
  51             %glibc-bootstrap-tarball
  52             %gcc-bootstrap-tarball
  53             %guile-bootstrap-tarball
  54             %mescc-tools-bootstrap-tarball
  55             %mes-bootstrap-tarball
  56             %bootstrap-tarballs
  57
  58             %guile-static-stripped
  59             %guile-3.0-static-stripped))
  60
  61 ;;; Commentary:
  62 ;;;
  63 ;;; This module provides tools to build tarballs of the "bootstrap binaries"
  64 ;;; used in (gnu packages bootstrap).  These statically-linked binaries are
  65 ;;; taken for granted and used as the root of the whole bootstrap procedure.
  66 ;;;
  67 ;;; Code:
  68
  69 (define glibc-for-bootstrap
  70   (mlambdaq (base)
  71     "Return a libc deriving from BASE whose `system' and `popen' functions looks
  72 for `sh' in $PATH, and without nscd, and with static NSS modules."
  73     (package
  74       (inherit base)
  75       (source (origin (inherit (package-source base))
  76                       (patches (cons (search-patch "glibc-bootstrap-system.patch")
  77                                      (origin-patches (package-source base))))))
  78       (arguments
  79        (substitute-keyword-arguments (package-arguments base)
  80          ((#:configure-flags flags)
  81           ;; Arrange so that getaddrinfo & co. do not contact the nscd,
  82           ;; and can use statically-linked NSS modules.
  83           `(cons* "--disable-nscd" "--disable-build-nscd"
  84                   "--enable-static-nss"
  85                   ,flags))))
  86
  87       ;; Remove the 'debug' output to allow bit-reproducible builds (when the
  88       ;; 'debug' output is used, ELF files end up with a .gnu_debuglink, which
  89       ;; includes a CRC of the corresponding debugging symbols; those symbols
  90       ;; contain store file names, so the CRC changes at every rebuild.)
  91       (outputs (delete "debug" (package-outputs base))))))
  92
  93 (define gcc-for-bootstrap
  94   (mlambdaq (glibc)
  95     "Return a variant of GCC that uses the bootstrap variant of GLIBC."
  96     (package
  97       (inherit gcc-5)
  98       (outputs '("out")) ;all in one so libgcc_s is easily found
  99       (inputs
 100        `( ;; Distinguish the name so we can refer to it below.
 101          ("bootstrap-libc" ,(glibc-for-bootstrap glibc))
 102          ("libc:static" ,(glibc-for-bootstrap glibc) "static")
 103          ,@(package-inputs gcc-5))))))
 104
 105 (define (package-with-relocatable-glibc p)
 106   "Return a variant of P that uses the libc as defined by
 107 `glibc-for-bootstrap'."
 108
 109   (define (cross-bootstrap-libc target)
 110     (glibc-for-bootstrap
 111      ;; `cross-libc' already returns a cross libc, so clear
 112      ;; %CURRENT-TARGET-SYSTEM.
 113      (parameterize ((%current-target-system #f))
 114        (cross-libc target))))
 115
 116   ;; Standard inputs with the above libc and corresponding GCC.
 117
 118   (define (inputs)
 119     (if (%current-target-system)                ; is this package cross built?
 120         `(("cross-libc"
 121            ,(cross-bootstrap-libc (%current-target-system)))
 122           ("cross-libc:static"
 123            ,(cross-bootstrap-libc (%current-target-system))
 124            "static"))
 125         '()))
 126
 127   (define (native-inputs)
 128     (if (%current-target-system)
 129         (let* ((target (%current-target-system))
 130                (xgcc (cross-gcc
 131                       target
 132                       #:xbinutils (cross-binutils target)
 133                       #:libc (cross-bootstrap-libc target))))
 134           `(("cross-gcc" ,(package
 135                             (inherit xgcc)
 136                             (search-paths
 137                              ;; Ensure the cross libc headers appears on the
 138                              ;; C++ system header search path.
 139                              (cons (search-path-specification
 140                                     (variable "CROSS_CPLUS_INCLUDE_PATH")
 141                                     (files '("include")))
 142                                    (package-search-paths gcc-5)))))
 143             ("cross-binutils" ,(cross-binutils target))
 144             ,@(%final-inputs)))
 145         `(("libc" ,(glibc-for-bootstrap glibc))
 146           ("libc:static" ,(glibc-for-bootstrap glibc) "static")
 147           ("gcc" ,(gcc-for-bootstrap glibc))
 148           ,@(fold alist-delete (%final-inputs) '("libc" "gcc")))))
 149
 150   (package-with-explicit-inputs p inputs
 151                                 (current-source-location)
 152                                 #:native-inputs native-inputs))
 153
 154 (define %static-inputs
 155   ;; Packages that are to be used as %BOOTSTRAP-INPUTS.
 156   (let ((coreutils (package (inherit coreutils)
 157                       (arguments
 158                        `(#:configure-flags
 159                          '("--disable-nls"
 160                            "--disable-silent-rules"
 161                            "--enable-no-install-program=stdbuf,libstdbuf.so"
 162                            "CFLAGS=-Os -g0"        ; smaller, please
 163                            "LDFLAGS=-static -pthread"
 164
 165                            ;; Work around a cross-compilation bug whereby libcoreutils.a
 166                            ;; would provide '__mktime_internal', which conflicts with the
 167                            ;; one in libc.a.
 168                            ,@(if (%current-target-system)
 169                                  `("gl_cv_func_working_mktime=yes")
 170                                  '()))
 171
 172                          #:tests? #f   ; signal-related Gnulib tests fail
 173                          ,@(package-arguments coreutils)))
 174
 175                       ;; Remove optional dependencies such as GMP.  Keep Perl
 176                       ;; except if it's missing (which is the case when
 177                       ;; cross-compiling).
 178                       (inputs (match (assoc "perl" (package-inputs coreutils))
 179                                 (#f '())
 180                                 (x  (list x))))
 181
 182                       ;; Remove the 'debug' output (see above for the reason.)
 183                       (outputs '("out"))))
 184         (bzip2 (package (inherit bzip2)
 185                  (arguments
 186                   (substitute-keyword-arguments (package-arguments bzip2)
 187                     ((#:phases phases)
 188                      `(modify-phases ,phases
 189                         (add-before 'build 'dash-static
 190                           (lambda _
 191                             (substitute* "Makefile"
 192                               (("^LDFLAGS[[:blank:]]*=.*$")
 193                                "LDFLAGS = -static"))
 194                             #t))))))))
 195         (xz (package (inherit xz)
 196               (outputs '("out"))
 197               (arguments
 198                `(#:strip-flags '("--strip-all")
 199                  #:phases (modify-phases %standard-phases
 200                             (add-before 'configure 'static-executable
 201                               (lambda _
 202                                 ;; Ask Libtool for a static executable.
 203                                 (substitute* "src/xz/Makefile.in"
 204                                   (("^xz_LDADD =")
 205                                    "xz_LDADD = -all-static"))
 206                                 #t)))))))
 207         (gawk (package (inherit gawk)
 208                 (source (origin (inherit (package-source gawk))
 209                           (patches (cons (search-patch "gawk-shell.patch")
 210                                          (origin-patches
 211                                           (package-source gawk))))))
 212                 (arguments
 213                  `(;; Starting from gawk 4.1.0, some of the tests for the
 214                    ;; plug-in mechanism just fail on static builds:
 215                    ;;
 216                    ;; ./fts.awk:1: error: can't open shared library `filefuncs' for reading (No such file or directory)
 217                    #:tests? #f
 218
 219                    ,@(substitute-keyword-arguments (package-arguments gawk)
 220                        ((#:phases phases)
 221                         `(modify-phases ,phases
 222                            (add-before 'configure 'no-export-dynamic
 223                              (lambda _
 224                                ;; Since we use `-static', remove
 225                                ;; `-export-dynamic'.
 226                                (substitute* "configure"
 227                                  (("-Wl,-export-dynamic") ""))
 228                                #t)))))))
 229                 (inputs (if (%current-target-system)
 230                             `(("bash" ,static-bash))
 231                             '()))))
 232         (tar (package (inherit tar)
 233                (arguments
 234                 `(;; Work around a cross-compilation bug whereby libgnu.a would provide
 235                   ;; '__mktime_internal', which conflicts with the one in libc.a.
 236                   ,@(if (%current-target-system)
 237                         `(#:configure-flags '("gl_cv_func_working_mktime=yes"))
 238                         '())
 239                   ,@(substitute-keyword-arguments (package-arguments tar)
 240                       ((#:phases phases)
 241                        `(modify-phases ,phases
 242                           (replace 'set-shell-file-name
 243                             (lambda _
 244                               ;; Do not use "/bin/sh" to run programs; see
 245                               ;; <http://lists.gnu.org/archive/html/guix-devel/2016-09/msg02272.html>.
 246                               (substitute* "src/system.c"
 247                                 (("/bin/sh") "sh")
 248                                 (("execv ") "execvp "))
 249                               #t)))))))))
 250         ;; We don't want to retain a reference to /gnu/store in the bootstrap
 251         ;; versions of egrep/fgrep, so we remove the custom phase added since
 252         ;; grep@2.25. The effect is 'egrep' and 'fgrep' look for 'grep' in
 253         ;; $PATH.
 254         (grep (package
 255                 (inherit grep)
 256                 (inputs '())                   ;remove PCRE, which is optional
 257                 (arguments
 258                  (substitute-keyword-arguments (package-arguments grep)
 259                    ((#:phases phases)
 260                     `(modify-phases ,phases
 261                        (delete 'fix-egrep-and-fgrep)))))))
 262         (finalize (compose static-package
 263                            package-with-relocatable-glibc)))
 264     `(,@(map (match-lambda
 265               ((name package)
 266                (list name (finalize package))))
 267              `(("tar" ,tar)
 268                ("gzip" ,gzip)
 269                ("bzip2" ,bzip2)
 270                ("xz" ,xz)
 271                ("patch" ,patch)
 272                ("coreutils" ,coreutils)
 273                ("sed" ,sed)
 274                ("grep" ,grep)
 275                ("gawk" ,gawk)))
 276       ("bash" ,static-bash))))
 277
 278 (define %static-binaries
 279   (package
 280     (name "static-binaries")
 281     (version "0")
 282     (build-system trivial-build-system)
 283     (source #f)
 284     (inputs %static-inputs)
 285     (arguments
 286      `(#:modules ((guix build utils))
 287        #:builder
 288        (begin
 289          (use-modules (ice-9 ftw)
 290                       (ice-9 match)
 291                       (srfi srfi-1)
 292                       (srfi srfi-26)
 293                       (guix build utils))
 294
 295          (let ()
 296           (define (directory-contents dir)
 297             (map (cut string-append dir "/" <>)
 298                  (scandir dir (negate (cut member <> '("." ".."))))))
 299
 300           (define (copy-directory source destination)
 301             (for-each (lambda (file)
 302                         (format #t "copying ~s...~%" file)
 303                         (copy-file file
 304                                    (string-append destination "/"
 305                                                   (basename file))))
 306                       (directory-contents source)))
 307
 308           (let* ((out (assoc-ref %outputs "out"))
 309                  (bin (string-append out "/bin")))
 310             (mkdir-p bin)
 311
 312             ;; Copy Coreutils binaries.
 313             (let* ((coreutils (assoc-ref %build-inputs "coreutils"))
 314                    (source    (string-append coreutils "/bin")))
 315               (copy-directory source bin))
 316
 317             ;; For the other inputs, copy just one binary, which has the
 318             ;; same name as the input.
 319             (for-each (match-lambda
 320                        ((name . dir)
 321                         (let ((source (string-append dir "/bin/" name)))
 322                           (format #t "copying ~s...~%" source)
 323                           (copy-file source
 324                                      (string-append bin "/" name)))))
 325                       (alist-delete "coreutils" %build-inputs))
 326
 327             ;; But of course, there are exceptions to this rule.
 328             (let ((grep (assoc-ref %build-inputs "grep")))
 329               (install-file (string-append grep "/bin/fgrep") bin)
 330               (install-file (string-append grep "/bin/egrep") bin))
 331
 332             ;; Clear references to the store path.
 333             (for-each remove-store-references
 334                       (directory-contents bin))
 335
 336             (with-directory-excursion bin
 337               ;; Programs such as Perl's build system want these aliases.
 338               (symlink "bash" "sh")
 339               (symlink "gawk" "awk"))
 340
 341             #t)))))
 342     (synopsis "Statically-linked bootstrap binaries")
 343     (description
 344      "Binaries used to bootstrap the distribution.")
 345     (license gpl3+)
 346     (home-page #f)))
 347
 348 (define %linux-libre-headers-stripped
 349   ;; The subset of Linux-Libre-Headers that we need.
 350   (package (inherit linux-libre-headers)
 351     (name (string-append (package-name linux-libre-headers) "-stripped"))
 352     (build-system trivial-build-system)
 353     (outputs '("out"))
 354     (arguments
 355      `(#:modules ((guix build utils)
 356                   (guix build make-bootstrap))
 357        #:builder
 358        (begin
 359          (use-modules (guix build utils)
 360                       (guix build make-bootstrap))
 361
 362          (let* ((in  (assoc-ref %build-inputs "linux-libre-headers"))
 363                 (out (assoc-ref %outputs "out")))
 364            (copy-linux-headers out in)
 365            #t))))
 366     (inputs `(("linux-libre-headers" ,linux-libre-headers)))))
 367
 368 (define %binutils-static
 369   ;; Statically-linked Binutils.
 370   (package (inherit binutils)
 371     (name "binutils-static")
 372     (arguments
 373      `(#:configure-flags (cons "--disable-gold"
 374                                ,(match (memq #:configure-flags
 375                                              (package-arguments binutils))
 376                                   ((#:configure-flags flags _ ...)
 377                                    flags)))
 378        #:make-flags ,(match (memq #:make-flags (package-arguments binutils))
 379                        ((#:make-flags flags _ ...)
 380                         flags)
 381                        (_ ''()))
 382        #:strip-flags '("--strip-all")
 383        #:phases (modify-phases %standard-phases
 384                   (add-before 'configure 'all-static
 385                     (lambda _
 386                       ;; The `-all-static' libtool flag can only be passed
 387                       ;; after `configure', since configure tests don't use
 388                       ;; libtool, and only for executables built with libtool.
 389                       (substitute* '("binutils/Makefile.in"
 390                                      "gas/Makefile.in"
 391                                      "ld/Makefile.in")
 392                         (("^LDFLAGS =(.*)$" line)
 393                          (string-append line
 394                                         "\nAM_LDFLAGS = -static -all-static\n")))
 395                       #t)))))))
 396
 397 (define %binutils-static-stripped
 398   ;; The subset of Binutils that we need.
 399   (package (inherit %binutils-static)
 400     (name (string-append (package-name %binutils-static) "-stripped"))
 401     (build-system trivial-build-system)
 402     (outputs '("out"))
 403     (arguments
 404      `(#:modules ((guix build utils))
 405        #:builder
 406        (begin
 407          (use-modules (guix build utils))
 408
 409          (setvbuf (current-output-port)
 410                   (cond-expand (guile-2.0 _IOLBF) (else 'line)))
 411          (let* ((in  (assoc-ref %build-inputs "binutils"))
 412                 (out (assoc-ref %outputs "out"))
 413                 (bin (string-append out "/bin")))
 414            (mkdir-p bin)
 415            (for-each (lambda (file)
 416                        (let ((target (string-append bin "/" file)))
 417                          (format #t "copying `~a'...~%" file)
 418                          (copy-file (string-append in "/bin/" file)
 419                                     target)
 420                          (remove-store-references target)))
 421                      '("ar" "as" "ld" "nm"  "objcopy" "objdump"
 422                        "ranlib" "readelf" "size" "strings" "strip"))
 423            #t))))
 424     (inputs `(("binutils" ,%binutils-static)))))
 425
 426 (define (%glibc-stripped)
 427   ;; GNU libc's essential shared libraries, dynamic linker, and headers,
 428   ;; with all references to store directories stripped.  As a result,
 429   ;; libc.so is unusable and need to be patched for proper relocation.
 430   (let ((glibc (glibc-for-bootstrap glibc)))
 431     (package (inherit glibc)
 432       (name "glibc-stripped")
 433       (build-system trivial-build-system)
 434       (arguments
 435        `(#:modules ((guix build utils)
 436                     (guix build make-bootstrap))
 437          #:builder
 438          (begin
 439            (use-modules (guix build make-bootstrap))
 440            (make-stripped-libc (assoc-ref %outputs "out")
 441                                (assoc-ref %build-inputs "libc")
 442                                (assoc-ref %build-inputs "kernel-headers")))))
 443       (inputs `(("kernel-headers"
 444                  ,(if (or (and (%current-target-system)
 445                                (hurd-triplet? (%current-target-system)))
 446                           (string-suffix? "-hurd" (%current-system)))
 447                       gnumach-headers
 448                       linux-libre-headers))
 449                 ("libc" ,(let ((target (%current-target-system)))
 450                            (if target
 451                                (glibc-for-bootstrap
 452                                 (parameterize ((%current-target-system #f))
 453                                   (cross-libc target)))
 454                                glibc)))))
 455       (native-inputs '())
 456       (propagated-inputs '())
 457
 458       ;; Only one output.
 459       (outputs '("out")))))
 460
 461 (define %gcc-static
 462   ;; A statically-linked GCC, with stripped-down functionality.
 463   (package-with-relocatable-glibc
 464    (package (inherit gcc-5)
 465      (name "gcc-static")
 466      (outputs '("out"))                           ; all in one
 467      (arguments
 468       (substitute-keyword-arguments (package-arguments gcc-5)
 469         ((#:modules modules %gnu-build-system-modules)
 470          `((srfi srfi-1)
 471            (srfi srfi-26)
 472            (ice-9 regex)
 473            ,@modules))
 474         ((#:guile _) #f)
 475         ((#:implicit-inputs? _) #t)
 476         ((#:configure-flags flags)
 477          `(append (list
 478                    ;; We don't need a full bootstrap here.
 479                    "--disable-bootstrap"
 480
 481                    ;; Make sure '-static' is passed where it matters.
 482                    "--with-stage1-ldflags=-static"
 483
 484                    ;; GCC 4.8+ requires a C++ compiler and library.
 485                    "--enable-languages=c,c++"
 486
 487                    ;; Make sure gcc-nm doesn't require liblto_plugin.so.
 488                    "--disable-lto"
 489
 490                    "--disable-shared"
 491                    "--disable-plugin"
 492                    "--disable-libmudflap"
 493                    "--disable-libatomic"
 494                    "--disable-libsanitizer"
 495                    "--disable-libitm"
 496                    "--disable-libgomp"
 497                    "--disable-libcilkrts"
 498                    "--disable-libvtv"
 499                    "--disable-libssp"
 500                    "--disable-libquadmath")
 501                   (remove (cut string-match "--(.*plugin|enable-languages)" <>)
 502                           ,flags)))
 503         ((#:phases phases)
 504          `(modify-phases ,phases
 505             (add-after 'pre-configure 'remove-lgcc_s
 506               (lambda _
 507                 ;; Remove the '-lgcc_s' added to GNU_USER_TARGET_LIB_SPEC in
 508                 ;; the 'pre-configure phase of our main gcc package, because
 509                 ;; that shared library is not present in this static gcc.  See
 510                 ;; <https://lists.gnu.org/archive/html/guix-devel/2015-01/msg00008.html>.
 511                 (substitute* (cons "gcc/config/rs6000/sysv4.h"
 512                                    (find-files "gcc/config"
 513                                                "^gnu-user.*\\.h$"))
 514                   ((" -lgcc_s}}") "}}"))
 515                 #t))))))
 516      (inputs
 517       `(("zlib:static" ,zlib "static")
 518         ("isl:static" ,isl-0.18 "static")
 519         ,@(package-inputs gcc-5)))
 520      (native-inputs
 521       (if (%current-target-system)
 522           `(;; When doing a Canadian cross, we need GMP/MPFR/MPC both
 523             ;; as target inputs and as native inputs; the latter is
 524             ;; needed when building build-time tools ('genconstants',
 525             ;; etc.)  Failing to do that leads to misdetections of
 526             ;; declarations by 'gcc/configure', and eventually to
 527             ;; duplicate declarations as reported in
 528             ;; <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=59217>.
 529             ("gmp-native" ,gmp)
 530             ("mpfr-native" ,mpfr)
 531             ("mpc-native" ,mpc)
 532             ,@(package-native-inputs gcc-5))
 533           (package-native-inputs gcc-5))))))
 534
 535 (define %gcc-stripped
 536   ;; The subset of GCC files needed for bootstrap.
 537   (package (inherit gcc-5)
 538     (name "gcc-stripped")
 539     (build-system trivial-build-system)
 540     (source #f)
 541     (outputs '("out"))                            ;only one output
 542     (arguments
 543      `(#:modules ((guix build utils))
 544        #:builder
 545        (begin
 546          (use-modules (srfi srfi-1)
 547                       (srfi srfi-26)
 548                       (guix build utils))
 549
 550          (setvbuf (current-output-port)
 551                   (cond-expand (guile-2.0 _IOLBF) (else 'line)))
 552          (let* ((out        (assoc-ref %outputs "out"))
 553                 (bindir     (string-append out "/bin"))
 554                 (libdir     (string-append out "/lib"))
 555                 (includedir (string-append out "/include"))
 556                 (libexecdir (string-append out "/libexec"))
 557                 (gcc        (assoc-ref %build-inputs "gcc")))
 558            (copy-recursively (string-append gcc "/bin") bindir)
 559            (for-each remove-store-references
 560                      (find-files bindir ".*"))
 561
 562            (copy-recursively (string-append gcc "/lib") libdir)
 563            (for-each remove-store-references
 564                      (remove (cut string-suffix? ".h" <>)
 565                              (find-files libdir ".*")))
 566
 567            (copy-recursively (string-append gcc "/libexec")
 568                              libexecdir)
 569            (for-each remove-store-references
 570                      (find-files libexecdir ".*"))
 571
 572            ;; Starting from GCC 4.8, helper programs built natively
 573            ;; (‘genchecksum’, ‘gcc-nm’, etc.) rely on C++ headers.
 574            (copy-recursively (string-append gcc "/include/c++")
 575                              (string-append includedir "/c++"))
 576
 577            ;; For native builds, check whether the binaries actually work.
 578            ,@(if (%current-target-system)
 579                  '()
 580                  '((for-each (lambda (prog)
 581                                (invoke (string-append gcc "/bin/" prog)
 582                                        "--version"))
 583                              '("gcc" "g++" "cpp"))))
 584
 585            #t))))
 586     (inputs `(("gcc" ,%gcc-static)))))
 587
 588 ;; Two packages: first build static, bare minimum content.
 589 (define %mescc-tools-static
 590   ;; A statically linked MesCC Tools.
 591   (package
 592     (inherit mescc-tools-0.5.2)
 593     (name "mescc-tools-static")
 594     (arguments
 595      `(#:system "i686-linux"
 596        ,@(substitute-keyword-arguments (package-arguments mescc-tools-0.5.2)
 597            ((#:make-flags flags)
 598             `(cons "CC=gcc -static" ,flags)))))))
 599
 600 ;; ... next remove store references.
 601 (define %mescc-tools-static-stripped
 602   ;; A statically linked Mescc Tools with store references removed, for
 603   ;; bootstrap.
 604   (package
 605     (inherit %mescc-tools-static)
 606     (name (string-append (package-name %mescc-tools-static) "-stripped"))
 607     (build-system trivial-build-system)
 608     (arguments
 609      `(#:modules ((guix build utils))
 610        #:builder
 611        (begin
 612          (use-modules (guix build utils))
 613          (let* ((in  (assoc-ref %build-inputs "mescc-tools"))
 614                 (out (assoc-ref %outputs "out"))
 615                 (bin (string-append out "/bin")))
 616            (mkdir-p bin)
 617            (for-each (lambda (file)
 618                        (let ((target (string-append bin "/" file)))
 619                          (format #t "copying `~a'...~%" file)
 620                          (copy-file (string-append in "/bin/" file)
 621                                     target)
 622                          (remove-store-references target)))
 623                      '( "M1" "blood-elf" "hex2"))
 624            #t))))
 625     (inputs `(("mescc-tools" ,%mescc-tools-static)))))
 626
 627 ;; Two packages: first build static, bare minimum content.
 628 (define-public %mes-minimal
 629   ;; A minimal Mes without documentation.
 630   (let ((triplet "i686-unknown-linux-gnu"))
 631     (package
 632       (inherit mes-0.19)
 633       (name "mes-minimal")
 634       (native-inputs
 635        `(("guile" ,guile-2.2)))
 636       (arguments
 637        `(#:system "i686-linux"
 638          #:strip-binaries? #f
 639          #:configure-flags '("--mes")
 640          #:phases
 641          (modify-phases %standard-phases
 642            (delete 'patch-shebangs)
 643            (add-after 'install 'strip-install
 644              (lambda _
 645                (let* ((out (assoc-ref %outputs "out"))
 646                       (share (string-append out "/share")))
 647                  (delete-file-recursively (string-append out "/lib/guile"))
 648                  (delete-file-recursively (string-append share "/guile"))
 649                  (delete-file-recursively (string-append share "/mes/scaffold"))
 650
 651                  (for-each delete-file
 652                            (find-files
 653                             (string-append share "/mes/lib")
 654                             "\\.(h|c)")))))))))))
 655
 656 ;; next remove store references.
 657 (define %mes-minimal-stripped
 658   ;; A minimal Mes with store references removed, for bootstrap.
 659   (package
 660     (inherit %mes-minimal)
 661     (name (string-append (package-name %mes-minimal) "-stripped"))
 662     (build-system trivial-build-system)
 663     (arguments
 664      `(#:modules ((guix build utils))
 665        #:builder
 666        (begin
 667          (use-modules (guix build utils))
 668          (let ((in  (assoc-ref %build-inputs "mes"))
 669                (out (assoc-ref %outputs "out")))
 670
 671            (copy-recursively in out)
 672            (for-each (lambda (dir)
 673                        (for-each remove-store-references
 674                                  (find-files (string-append out "/" dir)
 675                                              ".*")))
 676                      '("bin" "share/mes"))
 677            #t))))
 678     (inputs `(("mes" ,%mes-minimal)))))
 679
 680 (define* (make-guile-static guile patches)
 681   (package-with-relocatable-glibc
 682    (static-package
 683     (package
 684       (inherit guile)
 685       (source
 686        (origin (inherit (package-source guile))
 687                (patches (append (map search-patch patches)
 688                                 (origin-patches (package-source guile))))))
 689       (name (string-append (package-name guile) "-static"))
 690       (synopsis "Statically-linked and relocatable Guile")
 691
 692       ;; Remove the 'debug' output (see above for the reason.)
 693       (outputs (delete "debug" (package-outputs guile)))
 694
 695       (inputs
 696        `(("libunistring:static" ,libunistring "static")
 697          ,@(package-inputs guile)))
 698
 699       (propagated-inputs
 700        `(("bdw-gc" ,libgc/static-libs)
 701          ,@(alist-delete "bdw-gc"
 702                          (package-propagated-inputs guile))))
 703       (arguments
 704        (substitute-keyword-arguments (package-arguments guile)
 705          ((#:configure-flags flags '())
 706           ;; When `configure' checks for ltdl availability, it
 707           ;; doesn't try to link using libtool, and thus fails
 708           ;; because of a missing -ldl.  Work around that.
 709
 710           ;; XXX: On ARMv7, disable JIT: it causes crashes with 3.0.2,
 711           ;; possibly related to <https://bugs.gnu.org/40737>.
 712           (if (target-arm32?)
 713               ''("LDFLAGS=-ldl" "--disable-jit")
 714               ''("LDFLAGS=-ldl")))
 715          ((#:phases phases '%standard-phases)
 716           `(modify-phases ,phases
 717
 718              ;; Do not record the absolute file name of 'sh' in
 719              ;; (ice-9 popen).  This makes 'open-pipe' unusable in
 720              ;; a build chroot ('open-pipe*' is fine) but avoids
 721              ;; keeping a reference to Bash.
 722              (delete 'pre-configure)
 723
 724              (add-before 'configure 'static-guile
 725                (lambda _
 726                  (substitute* "libguile/Makefile.in"
 727                    ;; Create a statically-linked `guile'
 728                    ;; executable.
 729                    (("^guile_LDFLAGS =")
 730                     "guile_LDFLAGS = -all-static")
 731
 732                    ;; Add `-ldl' *after* libguile-2.0.la.
 733                    (("^guile_LDADD =(.*)$" _ ldadd)
 734                     (string-append "guile_LDADD = "
 735                                    (string-trim-right ldadd)
 736                                    " -ldl\n")))))))
 737          ((#:tests? _ #f)
 738           ;; There are uses of `dynamic-link' in
 739           ;; {foreign,coverage}.test that don't fly here.
 740           #f)
 741          ((#:parallel-build? _ #f)
 742           ;; Work around the fact that the Guile build system is
 743           ;; not deterministic when parallel-build is enabled.
 744           #f)))))))
 745
 746 (define %guile-static
 747   ;; A statically-linked Guile that is relocatable--i.e., it can search
 748   ;; .scm and .go files relative to its installation directory, rather
 749   ;; than in hard-coded configure-time paths.
 750   (make-guile-static guile-2.0 '("guile-relocatable.patch"
 751                                  "guile-default-utf8.patch"
 752                                  "guile-linux-syscalls.patch")))
 753
 754 (define* (make-guile-static-stripped static-guile)
 755   (package
 756     (inherit static-guile)
 757     (name (string-append (package-name static-guile) "-stripped"))
 758     (build-system trivial-build-system)
 759     (arguments
 760      ;; The end result should depend on nothing but itself.
 761      `(#:allowed-references ("out")
 762        #:modules ((guix build utils))
 763        #:builder
 764        (let ((version ,(version-major+minor (package-version static-guile))))
 765          (use-modules (guix build utils))
 766
 767          (let* ((in     (assoc-ref %build-inputs "guile"))
 768                 (out    (assoc-ref %outputs "out"))
 769                 (guile1 (string-append in "/bin/guile"))
 770                 (guile2 (string-append out "/bin/guile")))
 771            (mkdir-p (string-append out "/share/guile/" version))
 772            (copy-recursively (string-append in "/share/guile/" version)
 773                              (string-append out "/share/guile/" version))
 774
 775            (mkdir-p (string-append out "/lib/guile/" version "/ccache"))
 776            (copy-recursively (string-append in "/lib/guile/" version "/ccache")
 777                              (string-append out "/lib/guile/" version "/ccache"))
 778
 779            (mkdir (string-append out "/bin"))
 780            (copy-file guile1 guile2)
 781
 782            ;; Verify that the relocated Guile works.
 783            ,@(if (%current-target-system)
 784                  '()
 785                  '((invoke guile2 "--version")))
 786
 787            ;; Strip store references.
 788            (remove-store-references guile2)
 789
 790            ;; Verify that the stripped Guile works.  If it aborts, it could be
 791            ;; that it tries to open iconv descriptors and fails because libc's
 792            ;; iconv data isn't available (see `guile-default-utf8.patch'.)
 793            ,@(if (%current-target-system)
 794                  '()
 795                  '((invoke guile2 "--version")))
 796
 797            #t))))
 798     (inputs `(("guile" ,static-guile)))
 799     (outputs '("out"))
 800     (synopsis "Minimal statically-linked and relocatable Guile")))
 801
 802 (define %guile-static-stripped
 803   ;; A stripped static Guile binary, for use during bootstrap.
 804   (make-guile-static-stripped %guile-static))
 805
 806 (define %guile-3.0-static-stripped
 807   ;; A stripped static Guile 3.0 binary, for use in initrds.
 808   (make-guile-static-stripped
 809    (make-guile-static guile-3.0
 810                       '("guile-2.2-default-utf8.patch"
 811                         "guile-3.0-linux-syscalls.patch"
 812                         "guile-3.0-relocatable.patch"))))
 813
 814 (define (tarball-package pkg)
 815   "Return a package containing a tarball of PKG."
 816   (package (inherit pkg)
 817     (name (string-append (package-name pkg) "-tarball"))
 818     (build-system trivial-build-system)
 819     (native-inputs `(("tar" ,tar)
 820                      ("xz" ,xz)))
 821     (inputs `(("input" ,pkg)))
 822     (arguments
 823      (let ((name    (package-name pkg))
 824            (version (package-version pkg)))
 825        `(#:modules ((guix build utils))
 826          #:builder
 827          (begin
 828            (use-modules (guix build utils))
 829            (let ((out   (assoc-ref %outputs "out"))
 830                  (input (assoc-ref %build-inputs "input"))
 831                  (tar   (assoc-ref %build-inputs "tar"))
 832                  (xz    (assoc-ref %build-inputs "xz")))
 833              (mkdir out)
 834              (set-path-environment-variable "PATH" '("bin") (list tar xz))
 835              (with-directory-excursion input
 836                (invoke "tar" "cJvf"
 837                        (string-append out "/"
 838                                       ,name "-" ,version
 839                                       "-"
 840                                       ,(or (%current-target-system)
 841                                            (%current-system))
 842                                       ".tar.xz")
 843                        "."
 844                        ;; avoid non-determinism in the archive
 845                        "--sort=name" "--mtime=@0"
 846                        "--owner=root:0" "--group=root:0")))))))))
 847
 848 (define %bootstrap-binaries-tarball
 849   ;; A tarball with the statically-linked bootstrap binaries.
 850   (tarball-package %static-binaries))
 851
 852 (define %linux-libre-headers-bootstrap-tarball
 853   ;; A tarball with the statically-linked Linux-Libre-Headers programs.
 854   (tarball-package %linux-libre-headers-stripped))
 855
 856 (define %binutils-bootstrap-tarball
 857   ;; A tarball with the statically-linked Binutils programs.
 858   (tarball-package %binutils-static-stripped))
 859
 860 (define (%glibc-bootstrap-tarball)
 861   ;; A tarball with GNU libc's shared libraries, dynamic linker, and headers.
 862   (tarball-package (%glibc-stripped)))
 863
 864 (define %gcc-bootstrap-tarball
 865   ;; A tarball with a dynamic-linked GCC and its headers.
 866   (tarball-package %gcc-stripped))
 867
 868 (define %guile-bootstrap-tarball
 869   ;; A tarball with the statically-linked, relocatable Guile.
 870   (tarball-package %guile-static-stripped))
 871
 872 (define %mescc-tools-bootstrap-tarball
 873   ;; A tarball with statically-linked MesCC binary seed.
 874   (tarball-package %mescc-tools-static-stripped))
 875
 876 (define %mes-bootstrap-tarball
 877   ;; A tarball with Mes binary seed.
 878   (tarball-package %mes-minimal-stripped))
 879
 880 (define %bootstrap-tarballs
 881   ;; A single derivation containing all the bootstrap tarballs, for
 882   ;; convenience.
 883   (package
 884     (name "bootstrap-tarballs")
 885     (version "0")
 886     (source #f)
 887     (build-system trivial-build-system)
 888     (arguments
 889      `(#:modules ((guix build utils))
 890        #:builder
 891        (let ((out (assoc-ref %outputs "out")))
 892          (use-modules (guix build utils)
 893                       (ice-9 match)
 894                       (srfi srfi-26))
 895
 896          (setvbuf (current-output-port)
 897                   (cond-expand (guile-2.0 _IOLBF) (else 'line)))
 898          (mkdir out)
 899          (chdir out)
 900          (for-each (match-lambda
 901                     ((name . directory)
 902                      (for-each (lambda (file)
 903                                  (format #t "~a -> ~a~%" file out)
 904                                  (symlink file (basename file)))
 905                                (find-files directory "\\.tar\\."))))
 906                    %build-inputs)
 907          #t)))
 908     (inputs `(("guile-tarball" ,%guile-bootstrap-tarball)
 909               ,@(match (or (%current-target-system) (%current-system))
 910                   ((or "i686-linux" "x86_64-linux")
 911                    `(("bootstrap-mescc-tools" ,%mescc-tools-bootstrap-tarball)
 912                      ("bootstrap-mes" ,%mes-bootstrap-tarball)
 913                      ("bootstrap-linux-libre-headers"
 914                       ,%linux-libre-headers-bootstrap-tarball)))
 915                   (_ `(("gcc-tarball" ,%gcc-bootstrap-tarball)
 916                        ("binutils-tarball" ,%binutils-bootstrap-tarball)
 917                        ("glibc-tarball" ,(%glibc-bootstrap-tarball))
 918                        ("coreutils&co-tarball" ,%bootstrap-binaries-tarball))))))
 919     (synopsis "Tarballs containing all the bootstrap binaries")
 920     (description synopsis)
 921     (home-page #f)
 922     (license gpl3+)))
 923
 924 ;;; make-bootstrap.scm ends here