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'.

1 files changed, 76 insertions, 1 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