From 60f984b2627e55aafc963f04f7ef8dbccfec7f9a Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 1 Sep 2012 19:21:06 +0200
Subject: distro: Bootstrap standard inputs from Nixpkgs.

This is a first step towards bootstrapping from a set of pre-built,
statically-linked binaries.

* guix/build-system/gnu.scm (package-with-explicit-inputs,
  standard-inputs): New procedure.
  (%store): New variable.
  (%standard-inputs): Remove.
  (gnu-build): New `implicit-inputs?' keyword parameter.  Use it to
  choose whether to use `(standard-inputs SYSTEM)' or the empty list.

* distro/base.scm (guile-2.0): Remove dependency on XZ, which is now
  implicit.
  (%bootstrap-inputs, gcc-boot0, binutils-boot0, linux-headers-boot0,
  %boot1-inputs, glibc-final, %boot2-inputs, m4-boot2, gmp-boot2,
  mpfr-boot2, mpc-boot2, %boot3-inputs, gcc-final, %boot4-inputs,
  %final-inputs): New variables.
---
 distro/base.scm           | 176 ++++++++++++++++++++++++++++++++++++++++++++--
 guix/build-system/gnu.scm |  81 ++++++++++++++++++---
 2 files changed, 242 insertions(+), 15 deletions(-)

diff --git a/distro/base.scm b/distro/base.scm
index b0209256c3..99872213c0 100644
--- a/distro/base.scm
+++ b/distro/base.scm
@@ -21,7 +21,10 @@
   #:use-module (guix packages)
   #:use-module (guix http)
   #:use-module (guix build-system gnu)
-  #:use-module (guix utils))
+  #:use-module (guix utils)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match))
 
 ;;; Commentary:
 ;;;
@@ -613,7 +616,7 @@ BFD (Binary File Descriptor) library, `gprof', `nm', `strip', etc.")
                             ,(if stripped? "-g0" "-g"))))
 
         ;; Exclude libc from $LIBRARY_PATH since the compiler being used
-        ;; should know whether its libc is, and to avoid linking build tools
+        ;; should know where its libc is, and to avoid linking build tools
         ;; like `genhooks' against the wrong libc (for instance, when
         ;; building a gcc-for-glibc-2.16 with a gcc-for-glibc-2.13,
         ;; `genhooks' could end up being linked with glibc-2.16 but using
@@ -1031,8 +1034,7 @@ conversions for values passed between the two languages.")
              (base32
               "000ng5qsq3cl1k35jvzvhwxj92wx4q87745n2fppkd4irh58vv5l"))))
    (build-system gnu-build-system)
-   (native-inputs `(("xz" ,(nixpkgs-derivation* "xz"))
-                    ("pkgconfig" ,(nixpkgs-derivation* "pkgconfig"))))
+   (native-inputs `(("pkgconfig" ,(nixpkgs-derivation* "pkgconfig"))))
    (inputs `(("libffi" ,libffi)
              ("readline" ,readline)))
 
@@ -1169,6 +1171,171 @@ with the Linux kernel.")
    (license "LGPLv2+")
    (home-page "http://www.gnu.org/software/libc/")))
 
+
+;;;
+;;; Bootstrap packages.
+;;;
+
+(define %bootstrap-inputs
+  (compile-time-value
+   `(("libc" ,(nixpkgs-derivation "glibc"))
+     ,@(map (lambda (name)
+              (list name (nixpkgs-derivation name)))
+            '("gnutar" "gzip" "bzip2" "xz" "diffutils" "patch"
+              "coreutils" "gnused" "gnugrep" "bash"
+              "findutils"                           ; used by `libtool'
+              "gawk"                                ; used by `config.status'
+              "gcc" "binutils" "gnumake"
+              "gmp" "mpfr" "mpc")))))               ; TODO: remove from here?
+
+(define gcc-boot0
+  (package (inherit gcc-4.7)
+    (name "gcc-boot0")
+    (arguments
+     `(#:implicit-inputs? #f
+       ,@(package-arguments gcc-4.7)))
+    (inputs `(,@%bootstrap-inputs))))
+
+(define binutils-boot0
+  ;; Since Binutils in the bootstrap inputs may be too old, build ours here.
+  (package (inherit binutils)
+    (name "binutils-boot0")
+    (arguments
+     `(#:implicit-inputs? #f
+       ,@(package-arguments binutils)))
+    (inputs `(("gcc" ,gcc-boot0)
+              ,@(alist-delete "gcc" %bootstrap-inputs)))))
+
+(define linux-headers-boot0
+  (package (inherit linux-headers)
+    (arguments `(#:implicit-inputs? #f
+                 ,@(package-arguments linux-headers)))
+    (native-inputs `(("perl" ,(nixpkgs-derivation* "perl"))
+                     ,@%bootstrap-inputs))))
+
+(define %boot1-inputs
+  ;; 2nd stage inputs.
+  `(("gcc" ,gcc-boot0)
+    ("binutils" ,binutils-boot0)
+    ,@(fold alist-delete %bootstrap-inputs
+            '("gcc" "binutils"))))
+
+(define-public glibc-final
+  ;; The final libc.
+  ;; FIXME: It depends on GCC-BOOT0, which depends on some of
+  ;; %BOOTSTRAP-INPUTS.
+  (package (inherit glibc)
+    (arguments
+     `(#:implicit-inputs? #f
+
+       ;; Leave /bin/sh as the interpreter for `ldd', `sotruss', etc. to
+       ;; avoid keeping a reference to the bootstrap Bash.
+       #:patch-shebangs? #f
+       ,@(let loop ((args   (package-arguments glibc))
+                    (before '()))
+           (match args
+             ((#:configure-flags ('list cf ...) after ...)
+              (append (reverse before)
+                      `(#:configure-flags (list "BASH_SHELL=/bin/sh" ,@cf))
+                      after))
+             ((x rest ...)
+              (loop rest (cons x before)))))))
+    (propagated-inputs `(("linux-headers" ,linux-headers-boot0)))
+    (inputs %boot1-inputs)))
+
+(define %boot2-inputs
+  ;; 3rd stage inputs.
+  `(("libc" ,glibc-final)
+    ,@(alist-delete "libc" %bootstrap-inputs)))
+
+(define m4-boot2
+  (package (inherit m4)
+    (name "m4-boot2")
+    (arguments (lambda (system)
+                 `(#:implicit-inputs? #f
+                   ,@((package-arguments m4) system))))
+    (inputs `(,@(package-inputs m4)
+              ,@%boot2-inputs))))
+
+(define gmp-boot2
+  (package (inherit gmp)
+    (name "gmp-boot2")
+    (arguments
+     `(#:implicit-inputs? #f
+       ,@(package-arguments gmp)))
+    (native-inputs `(("m4" ,m4-boot2)
+                     ,@%boot2-inputs))))
+
+(define mpfr-boot2
+  (package (inherit mpfr)
+    (name "mpfr-boot2")
+    (arguments
+     `(#:implicit-inputs? #f
+       ,@(package-arguments mpfr)))
+    (inputs `(("gmp" ,gmp-boot2)
+              ,@%boot2-inputs))))
+
+(define mpc-boot2
+  (package (inherit mpc)
+    (name "mpc-boot2")
+    (arguments
+     `(#:implicit-inputs? #f
+       ,@(package-arguments mpc)))
+    (inputs `(("gmp" ,gmp-boot2)
+              ("mpfr" ,mpfr-boot2)
+              ,@%boot2-inputs))))
+
+(define %boot3-inputs
+  ;; 4th stage inputs.
+  `(("libc" ,glibc-final)
+    ("gmp" ,gmp-boot2)
+    ("mpfr" ,mpfr-boot2)
+    ("mpc" ,mpc-boot2)
+    ,@(fold alist-delete
+            %boot2-inputs
+            '("libc" "gmp" "mpfr" "mpc"))))
+
+(define-public gcc-final
+  ;; The final GCC.
+  (package (inherit gcc-boot0)
+    (name "gcc")
+    (inputs %boot3-inputs)))
+
+(define %boot4-inputs
+  ;; 5th stage inputs.
+  `(("gcc" ,gcc-final)
+    ,@(fold alist-delete %boot3-inputs
+            '("gcc" "gmp" "mpfr" "mpc"))))
+
+(define-public %final-inputs
+  ;; Final derivations used as implicit inputs by `gnu-build-system'.
+  (let ((finalize (cut package-with-explicit-inputs <> %boot4-inputs
+                       (source-properties->location
+                        (current-source-location)))))
+    `(,@(map (match-lambda
+              ((name package)
+               (list name (finalize package))))
+             `(("tar" ,tar)
+               ("gzip" ,gzip)
+               ("xz" ,xz)
+               ("diffutils" ,diffutils)
+               ("patch" ,patch)
+               ("coreutils" ,coreutils)
+               ("sed" ,sed)
+               ("grep" ,grep)
+               ("bash" ,bash)
+               ("findutils" ,findutils)
+               ("gawk" ,gawk)
+               ("make" ,gnu-make)
+               ("binutils" ,binutils)))
+      ("gcc" ,gcc-final)
+      ("glibc" ,glibc-final))))
+
+
+;;;
+;;; Apps & libs --- TODO: move to separate module.
+;;;
+
 (define (guile-reader guile)
   "Build Guile-Reader against GUILE, a package of some version of Guile 1.8
 or 2.0."
@@ -1322,4 +1489,5 @@ beginning.")
 ;;; eval: (put 'lambda* 'scheme-indent-function 1)
 ;;; eval: (put 'substitute* 'scheme-indent-function 1)
 ;;; eval: (put 'with-directory-excursion 'scheme-indent-function 1)
+;;; eval: (put 'package 'scheme-indent-function 1)
 ;;; End:
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index f4e7c1bcc4..32cb6bfae7 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -21,9 +21,13 @@
   #:use-module (guix utils)
   #:use-module (guix derivations)
   #:use-module (guix build-system)
+  #:use-module (guix packages)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-39)
+  #:use-module (ice-9 match)
   #:export (gnu-build
-            gnu-build-system))
+            gnu-build-system
+            package-with-explicit-inputs))
 
 ;; Commentary:
 ;;
@@ -32,15 +36,66 @@
 ;;
 ;; Code:
 
-(define %standard-inputs
-  (compile-time-value
-   (map (lambda (name)
-          (list name (nixpkgs-derivation name)))
-        '("gnutar" "gzip" "bzip2" "xz" "diffutils" "patch"
-          "coreutils" "gnused" "gnugrep" "bash"
-          "findutils"                             ; used by `libtool'
-          "gawk"                                  ; used by `config.status'
-          "gcc" "binutils" "gnumake" "glibc"))))
+(define* (package-with-explicit-inputs p boot-inputs
+                                       #:optional
+                                       (loc (source-properties->location
+                                             (current-source-location))))
+  "Rewrite P, which is assumed to use GNU-BUILD-SYSTEM, to take BOOT-INPUTS
+as explicit inputs instead of the implicit default, and return it."
+  (define rewritten-input
+    (match-lambda
+     ((name (? package? p) sub-drv ...)
+      (cons* name (package-with-explicit-inputs p boot-inputs) sub-drv))
+     (x x)))
+
+  (define boot-input-names
+    (map car boot-inputs))
+
+  (define (filtered-inputs inputs)
+    (fold alist-delete inputs boot-input-names))
+
+  (package (inherit p)
+    (location loc)
+    (arguments
+     (let ((args (package-arguments p)))
+       (if (procedure? args)
+           (lambda (system)
+             `(#:implicit-inputs? #f ,@(args system)))
+           `(#:implicit-inputs? #f ,@args))))
+    (native-inputs (map rewritten-input
+                        (filtered-inputs (package-native-inputs p))))
+    (propagated-inputs (map rewritten-input
+                            (filtered-inputs
+                             (package-propagated-inputs p))))
+    (inputs `(,@boot-inputs
+              ,@(map rewritten-input
+                     (filtered-inputs (package-inputs p)))))))
+
+(define %store
+  ;; Store passed to STANDARD-INPUTS.
+  (make-parameter #f))
+
+(define standard-inputs
+  (memoize
+   (lambda (system)
+     "Return the list of implicit standard inputs used with the GNU Build
+System: GCC, GNU Make, Bash, Coreutils, etc."
+     (map (match-lambda
+           ((name pkg sub-drv ...)
+            (cons* name (package-derivation (%store) pkg system) sub-drv))
+           ((name (? derivation-path? path) sub-drv ...)
+            (cons* name path sub-drv))
+           (z
+            (error "invalid standard input" z)))
+
+          ;; Resolve (distro base) lazily to hide circular dependency.
+          (let* ((distro (resolve-module '(distro base)))
+                 (inputs (module-ref distro '%final-inputs)))
+            (append inputs
+                    (append-map (match-lambda
+                                 ((name package _ ...)
+                                  (package-transitive-propagated-inputs package)))
+                                inputs)))))))
 
 (define* (gnu-build store name source inputs
                     #:key (outputs '("out")) (configure-flags ''())
@@ -57,6 +112,7 @@
                                           "bin" "sbin"))
                     (phases '%standard-phases)
                     (system (%current-system))
+                    (implicit-inputs? #t)         ; useful when bootstrapping
                     (modules '((guix build gnu-build-system)
                                (guix build utils))))
   "Return a derivation called NAME that builds from tarball SOURCE, with
@@ -88,7 +144,10 @@ input derivation INPUTS, using the usual procedure of the GNU Build System."
                                 builder
                                 `(("source" ,source)
                                   ,@inputs
-                                  ,@%standard-inputs)
+                                  ,@(if implicit-inputs?
+                                        (parameterize ((%store store))
+                                          (standard-inputs system))
+                                        '()))
                                 #:outputs outputs
                                 #:modules modules))
 
-- 
cgit v1.2.3