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