From a3f75312ec6fb170f2a60a80442a92648db1f5c2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 11 Oct 2012 00:03:31 +0200
Subject: [PATCH] distro: First stab at building statically-linked bootstrap
 binaries.

* distro/packages/base.scm (static-package): New procedure.
  (%bash-static, %static-inputs, %static-binaries): New variables.
---
 distro/packages/base.scm | 168 +++++++++++++++++++++++++++++++++++++++
 1 file changed, 168 insertions(+)

diff --git a/distro/packages/base.scm b/distro/packages/base.scm
index 88fa1bb27c..f2a93f8601 100644
--- a/distro/packages/base.scm
+++ b/distro/packages/base.scm
@@ -1815,4 +1815,172 @@ store.")
       ("gcc" ,gcc-final)
       ("libc" ,glibc-final))))
 
+
+;;;
+;;; Bootstrap binaries.
+;;;
+;;; These are the binaries that are taken for granted and used as the
+;;; root of the whole bootstrap procedure.
+;;;
+
+(define* (static-package p #:optional (loc (current-source-location)))
+  "Return a statically-linked version of package P."
+  ;; TODO: Move to (guix build-system gnu).
+  (let ((args (package-arguments p)))
+    (package (inherit p)
+      (location (source-properties->location loc))
+      (arguments
+       (let ((augment (lambda (args)
+                        (let ((a (default-keyword-arguments args
+                                   '(#:configure-flags '()
+                                     #:strip-flags #f))))
+                          (substitute-keyword-arguments a
+                            ((#:configure-flags flags)
+                             `(cons* "--disable-shared"
+                                     "LDFLAGS=-static"
+                                     ,flags))
+                            ((#:strip-flags _)
+                             ''("--strip-all")))))))
+         (if (procedure? args)
+             (lambda x
+               (augment (apply args x)))
+             (augment args)))))))
+
+(define %bash-static
+  (let ((bash-light (package (inherit bash-final)
+                      (inputs '())              ; no readline, no curses
+                      (arguments
+                       (let ((args `(#:modules ((guix build gnu-build-system)
+                                                (guix build utils)
+                                                (srfi srfi-1)
+                                                (srfi srfi-26))
+                                               ,@(package-arguments bash))))
+                         (substitute-keyword-arguments args
+                           ((#:configure-flags flags)
+                            `(list "--without-bash-malloc"
+                                   "--disable-readline"
+                                   "--disable-history"
+                                   "--disable-help-builtin"
+                                   "--disable-progcomp"
+                                   "--disable-net-redirections"
+                                   "--disable-nls"))))))))
+    (static-package bash-light)))
+
+(define %static-inputs
+  ;; Packages that are to be used as %BOOTSTRAP-INPUTS.
+  (let ((coreutils (package (inherit coreutils)
+                     (arguments
+                      `(#:configure-flags
+                        '("--disable-nls"
+                          "--disable-silent-rules"
+                          "--enable-no-install-program=stdbuf,libstdbuf.so"
+                          "LDFLAGS=-static -pthread")
+                        ,@(package-arguments coreutils)))))
+        (bzip2 (package (inherit bzip2)
+                 (arguments
+                  (substitute-keyword-arguments (package-arguments bzip2)
+                    ((#:phases phases)
+                     `(alist-cons-before
+                       'build 'dash-static
+                       (lambda _
+                         (substitute* "Makefile"
+                           (("^LDFLAGS[[:blank:]]*=.*$")
+                            "LDFLAGS = -static")))
+                       ,phases))))))
+        (xz (package (inherit xz)
+              (arguments
+               `(#:strip-flags '("--strip-all")
+                 #:phases (alist-cons-before
+                           'configure 'static-executable
+                           (lambda _
+                             ;; Ask Libtool for a static executable.
+                             (substitute* "src/xz/Makefile.in"
+                               (("^xz_LDADD =")
+                                "xz_LDADD = -all-static")))
+                           %standard-phases)))))
+        (gawk (package (inherit gawk)
+                (arguments
+                 (lambda (system)
+                   `(#:phases (alist-cons-before
+                               'build 'no-export-dynamic
+                               (lambda* (#:key outputs #:allow-other-keys)
+                                 ;; Since we use `-static', remove
+                                 ;; `-export-dynamic'.
+                                 (substitute* "configure"
+                                  (("-export-dynamic") "")))
+                               %standard-phases)
+                     ,@((package-arguments gawk) system)))))))
+    `(,@(map (match-lambda
+              ((name package)
+               (list name (static-package package (current-source-location)))))
+             `(("tar" ,tar)
+               ("gzip" ,gzip)
+               ("bzip2" ,bzip2)
+               ("xz" ,xz)
+               ("patch" ,patch)
+               ("coreutils" ,coreutils)
+               ("sed" ,sed)
+               ("grep" ,grep)
+               ("gawk" ,gawk)))
+      ("bash" ,%bash-static)
+      ;; ("ld-wrapper" ,ld-wrapper)
+      ;; ("binutils" ,binutils-final)
+      ;; ("gcc" ,gcc-final)
+      ;; ("libc" ,glibc-final)
+      )))
+
+(define %static-binaries
+  (package
+    (name "static-binaries")
+    (version "0")
+    (build-system trivial-build-system)
+    (source #f)
+    (inputs %static-inputs)
+    (arguments
+     `(#:builder
+       (begin
+         (use-modules (ice-9 ftw)
+                      (ice-9 match)
+                      (srfi srfi-1)
+                      (srfi srfi-26))
+
+         (let ()
+          (define (directory-contents dir)
+            (map (cut string-append dir "/" <>)
+                 (scandir dir (negate (cut member <> '("." ".."))))))
+
+          (define (copy-directory source destination)
+            (for-each (lambda (file)
+                        (format #t "copying ~s...~%" file)
+                        (copy-file file
+                                   (string-append destination "/"
+                                                  (basename file))))
+                      (directory-contents source)))
+
+          (let* ((out (assoc-ref %outputs "out"))
+                 (bin (string-append out "/bin")))
+            (mkdir out) (mkdir bin)
+
+            ;; Copy Coreutils binaries.
+            (let* ((coreutils (assoc-ref %build-inputs "coreutils"))
+                   (source    (string-append coreutils "/bin")))
+              (copy-directory source bin))
+
+            ;; For the other inputs, copy just one binary, which has the
+            ;; same name as the input.
+            (for-each (match-lambda
+                       ((name . dir)
+                        (let ((source (string-append dir "/bin/" name)))
+                          (format #t "copying ~s...~%" source)
+                          (copy-file source
+                                     (string-append bin "/" name)))))
+                      (alist-delete "coreutils" %build-inputs))
+
+            #t)))))
+    (description "Statically-linked bootstrap binaries")
+    (long-description
+     "Binaries used to bootstrap the distribution.")
+    (license #f)
+    (home-page #f)))
+
 ;;; base.scm ends here