linux-initrd: Move initrd creation code to (guix build linux-initrd).

* gnu/build/linux-initrd.scm (cache-compiled-file-name,
  compile-to-cache, build-initrd): New procedures.
* gnu/system/linux-initrd.scm (expression->initrd)[builder]: Remove code
  now moved above.  Use 'build-initrd'.

2 files changed, 84 insertions, 56 deletions

diff --git a/gnu/build/linux-initrd.scm b/gnu/build/linux-initrd.scm
index bf60137e8f..2c0acb200e 100644
--- a/gnu/build/linux-initrd.scm
+++ b/gnu/build/linux-initrd.scm
@@ -17,9 +17,15 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu build linux-initrd)
+  #:use-module (guix build utils)
+  #:use-module (guix build store-copy)
+  #:use-module (system base compile)
+  #:use-module (rnrs bytevectors)
+  #:use-module ((system foreign) #:select (sizeof))
   #:use-module (ice-9 popen)
   #:use-module (ice-9 ftw)
-  #:export (write-cpio-archive))
+  #:export (write-cpio-archive
+            build-initrd))
 
 ;;; Commentary:
 ;;;
@@ -69,4 +75,73 @@ COMPRESS? is true, compress it using GZIP.  On success, return OUTPUT."
                                output))
              output))))
 
+(define (cache-compiled-file-name file)
+  "Return the file name of the in-cache .go file for FILE, relative to the
+current directory.
+
+This is similar to what 'compiled-file-name' in (system base compile) does."
+  (let loop ((file file))
+    (let ((target (false-if-exception (readlink file))))
+     (if target
+         (loop target)
+         (format #f ".cache/guile/ccache/~a-~a-~a-~a/~a"
+                 (effective-version)
+                 (if (eq? (native-endianness) (endianness little))
+                     "LE"
+                     "BE")
+                 (sizeof '*)
+                 (effective-version)
+                 file)))))
+
+(define (compile-to-cache file)
+  "Compile FILE to the cache."
+  (let ((compiled-file (cache-compiled-file-name file)))
+    (mkdir-p (dirname compiled-file))
+    (compile-file file
+                  #:opts %auto-compilation-options
+                  #:output-file compiled-file)))
+
+(define* (build-initrd output
+                       #:key
+                       guile init
+                       linux-module-directory
+                       (references-graphs '())
+                       (cpio "cpio")
+                       (gzip "gzip"))
+  "Write an initial RAM disk (initrd) to OUTPUT.  The initrd starts the script
+at INIT, running GUILE.  It contains all the items referred to by
+REFERENCES-GRAPHS, plus the Linux modules from LINUX-MODULE-DIRECTORY."
+  (mkdir "contents")
+
+  ;; Copy the closures of all the items referenced in REFERENCES-GRAPHS.
+  (populate-store references-graphs "contents")
+
+  (with-directory-excursion "contents"
+    ;; Copy Linux modules.
+    (mkdir "modules")
+    (copy-recursively linux-module-directory "modules")
+
+    ;; Make '/init'.
+    (symlink init "init")
+
+    ;; Compile it.
+    (compile-to-cache "init")
+
+    ;; Allow Guile to find out where it is (XXX).  See
+    ;; 'guile-relocatable.patch'.
+    (mkdir-p "proc/self")
+    (symlink (string-append guile "/bin/guile") "proc/self/exe")
+    (readlink "proc/self/exe")
+
+    ;; Reset the timestamps of all the files that will make it in the initrd.
+    (for-each (lambda (file)
+                (unless (eq? 'symlink (stat:type (lstat file)))
+                  (utime file 0 0 0 0)))
+              (find-files "." ".*"))
+
+    (write-cpio-archive output "."
+                        #:cpio cpio #:gzip gzip))
+
+  (delete-file-recursively "contents"))
+
 ;;; linux-initrd.scm ends here
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index b05cfc5bcd..c2c8722ebb 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -81,64 +81,17 @@ initrd."
                     (length to-copy)))
 
     (define builder
-      ;; TODO: Move most of this code to (gnu build linux-initrd).
       #~(begin
-          (use-modules (gnu build linux-initrd)
-                       (guix build utils)
-                       (guix build store-copy)
-                       (system base compile)
-                       (rnrs bytevectors)
-                       ((system foreign) #:select (sizeof)))
+          (use-modules (gnu build linux-initrd))
 
           (mkdir #$output)
-          (mkdir "contents")
-
-          (with-directory-excursion "contents"
-            ;; Copy Linux modules.
-            (mkdir "modules")
-            (copy-recursively #$module-dir "modules")
-
-            ;; Populate the initrd's store.
-            (with-directory-excursion ".."
-              (populate-store '#$graph-files "contents"))
-
-            ;; Make '/init'.
-            (symlink #$init "init")
-
-            ;; Compile it.
-            (let* ((init    (readlink "init"))
-                   (scm-dir (string-append "share/guile/" (effective-version)))
-                   (go-dir  (format #f ".cache/guile/ccache/~a-~a-~a-~a/~a"
-                                    (effective-version)
-                                    (if (eq? (native-endianness) (endianness little))
-                                        "LE"
-                                        "BE")
-                                    (sizeof '*)
-                                    (effective-version)
-                                    (dirname init))))
-              (mkdir-p go-dir)
-              (compile-file init
-                            #:opts %auto-compilation-options
-                            #:output-file (string-append go-dir "/"
-                                                         (basename init)
-                                                         ".go")))
-
-            ;; This hack allows Guile to find out where it is.  See
-            ;; 'guile-relocatable.patch'.
-            (mkdir-p "proc/self")
-            (symlink (string-append #$guile "/bin/guile") "proc/self/exe")
-            (readlink "proc/self/exe")
-
-            ;; Reset the timestamps of all the files that will make it in the
-            ;; initrd.
-            (for-each (lambda (file)
-                        (unless (eq? 'symlink (stat:type (lstat file)))
-                          (utime file 0 0 0 0)))
-                      (find-files "." ".*"))
-
-            (write-cpio-archive (string-append #$output "/initrd") "."
-                                #:cpio (string-append #$cpio "/bin/cpio")
-                                #:gzip (string-append #$gzip "/bin/gzip")))))
+          (build-initrd (string-append #$output "/initrd")
+                        #:guile #$guile
+                        #:init #$init
+                        #:references-graphs '#$graph-files
+                        #:linux-module-directory #$module-dir
+                        #:cpio (string-append #$cpio "/bin/cpio")
+                        #:gzip (string-append #$gzip "/bin/gzip"))))
 
    (gexp->derivation name builder
                      #:modules '((guix build utils)