From ca6c4fa190e95efba7ade83a0decb19de084f4f5 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 14 Dec 2013 16:31:01 +0100
Subject: pull: Compile files in parallel.

* guix/scripts/pull.scm (unpack)[builder](compile-file*): Remove.
  (call-with-process, p-for-each): New procedures.  Use them to compile
  files in parallel.
---
 guix/scripts/pull.scm | 69 +++++++++++++++++++++++++++++++++++----------------
 1 file changed, 47 insertions(+), 22 deletions(-)

(limited to 'guix/scripts/pull.scm')

diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 23f20493d1..e56897986a 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -59,29 +59,49 @@ (define builder
              (gcrypt  (assoc-ref %build-inputs "gcrypt"))
              (tarball (assoc-ref %build-inputs "tarball")))
 
-         (define* (compile-file* file #:key output-file (opts '()))
-           ;; Like 'compile-file', but in a separate process, to work around
-           ;; <http://bugs.gnu.org/15602> (FIXME).  This ensures correctness,
-           ;; but is overly conservative and very slow.  The solution
-           ;; initially implemented (and described in the bug above) was
-           ;; slightly faster but consumed memory proportional to the number
-           ;; of modules, which quickly became unacceptable.
+         (define (call-with-process thunk)
+           ;; Run THUNK in a separate process that will return 0 if THUNK
+           ;; terminates normally, and 1 if an exception is raised.
            (match (primitive-fork)
              (0
               (catch #t
                 (lambda ()
-                  (compile-file file
-                                #:output-file output-file
-                                #:opts opts)
+                  (thunk)
                   (primitive-exit 0))
                 (lambda (key . args)
                   (print-exception (current-error-port) #f key args)
                   (primitive-exit 1))))
              (pid
-              (match (waitpid pid)
-                ((_ . status)
-                 (unless (zero? (status:exit-val status))
-                   (error "failed to compile file" file status)))))))
+              #t)))
+
+         (define (p-for-each proc lst)
+           ;; Invoke PROC for each element of LST in a separate process.
+           ;; Raise an error if one of the processes exit with non-zero.
+           (define (wait-for-one-process)
+             (match (waitpid WAIT_ANY)
+               ((_ . status)
+                (unless (zero? (status:exit-val status))
+                  (error "process failed" proc status)))))
+
+           (define max-processes
+             (current-processor-count))
+
+           (let loop ((lst   lst)
+                      (running 0))
+             (match lst
+               (()
+                (or (zero? running)
+                    (begin
+                      (wait-for-one-process)
+                      (loop lst (- running 1)))))
+               ((head . tail)
+                (if (< running max-processes)
+                    (begin
+                      (call-with-process (cut proc head))
+                      (loop tail (+ running 1)))
+                    (begin
+                      (wait-for-one-process)
+                      (loop lst (- running 1))))))))
 
          (setenv "PATH" (string-append tar "/bin:" gzip "/bin"))
 
@@ -113,19 +133,24 @@ (define* (compile-file* file #:key output-file (opts '()))
          (set! %load-path (cons out %load-path))
          (set! %load-compiled-path (cons out %load-compiled-path))
 
-         ;; Compile the .scm files.
-         (for-each (lambda (file)
-                     (when (string-suffix? ".scm" file)
+         ;; Compile the .scm files.  Do that in independent processes, à la
+         ;; 'make -j', to work around <http://bugs.gnu.org/15602> (FIXME).
+         ;; This ensures correctness, but is overly conservative and slow.
+         ;; The solution initially implemented (and described in the bug
+         ;; above) was slightly faster but consumed memory proportional to the
+         ;; number of modules, which quickly became unacceptable.
+         (p-for-each (lambda (file)
                        (let ((go (string-append (string-drop-right file 4)
                                                 ".go")))
                          (format (current-error-port)
                                  "compiling '~a'...~%" file)
-                         (compile-file* file
-                                        #:output-file go
-                                        #:opts
-                                        %auto-compilation-options))))
+                         (compile-file file
+                                       #:output-file go
+                                       #:opts
+                                       %auto-compilation-options)))
 
-                   (find-files out "\\.scm"))
+                     (filter (cut string-suffix? ".scm" <>)
+                             (find-files out "\\.scm")))
 
          ;; Remove the "fake" (guix config).
          (delete-file (string-append out "/guix/config.scm"))
-- 
cgit v1.2.3