From: Christopher Baines <mail@cbaines.net>
To: 34982@debbugs.gnu.org
Subject: [bug#34982] [PATCH] guile-build-system: Support building in parallel.
Date: Tue, 16 Apr 2019 19:13:26 +0100 [thread overview]
Message-ID: <20190416181326.2416-1-mail@cbaines.net> (raw)
In-Reply-To: <20190324212345.4697-1-mail@cbaines.net>
* guix/build/guile-build-system.scm (build): Use invoke-each, instead of
for-each, to use multiple cores if available.
(invoke-each, report-build-process): New procedures.
---
guix/build/guile-build-system.scm | 96 +++++++++++++++++++++++++------
1 file changed, 78 insertions(+), 18 deletions(-)
diff --git a/guix/build/guile-build-system.scm b/guix/build/guile-build-system.scm
index 0bed049436..5ad728361a 100644
--- a/guix/build/guile-build-system.scm
+++ b/guix/build/guile-build-system.scm
@@ -23,6 +23,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:use-module (ice-9 rdelim)
+ #:use-module (ice-9 threads)
#:use-module (guix build utils)
#:export (target-guile-effective-version
%standard-phases
@@ -65,6 +66,59 @@ Return #false if it cannot be determined."
(setenv "GUIX_LOCPATH" (string-append locales "/lib/locale"))
#t)))
+(define* (invoke-each commands
+ #:key (max-processes (current-processor-count))
+ report-progress)
+ "Run each command in COMMANDS in a separate process, using up to
+MAX-PROCESSES processes in parallel. Call REPORT-PROGRESS at each step.
+Raise an error if one of the processes exit with non-zero."
+ (define total
+ (length commands))
+
+ (define (wait-for-one-process)
+ (match (waitpid WAIT_ANY)
+ ((_ . status)
+ (unless (zero? (status:exit-val status))
+ (error "process failed" status)))))
+
+ (define (fork-and-run-command command)
+ (match (primitive-fork)
+ (0
+ (apply execlp command))
+ (pid
+ #t)))
+
+ (let loop ((commands commands)
+ (running 0)
+ (completed 0))
+ (match commands
+ (()
+ (or (zero? running)
+ (let ((running (- running 1))
+ (completed (+ completed 1)))
+ (wait-for-one-process)
+ (report-progress total completed)
+ (loop commands running completed))))
+ ((command . rest)
+ (if (< running max-processes)
+ (let ((running (+ 1 running)))
+ (fork-and-run-command command)
+ (report-progress total completed)
+ (loop rest running completed))
+ (let ((running (- running 1))
+ (completed (+ completed 1)))
+ (wait-for-one-process)
+ (report-progress total completed)
+ (loop commands running completed)))))))
+
+(define* (report-build-progress total completed
+ #:optional (log-port (current-error-port)))
+ "Report that COMPLETED out of TOTAL files have been completed."
+ (display #\cr log-port)
+ (format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n
+ (* 100. (/ completed total)) total)
+ (force-output log-port))
+
(define* (build #:key outputs inputs native-inputs
(source-directory ".")
(compile-flags '())
@@ -101,24 +155,30 @@ Return #false if it cannot be determined."
(match (getenv "GUILE_LOAD_COMPILED_PATH")
(#f "")
(path (string-append ":" path)))))
- (for-each (lambda (file)
- (let* ((go (string-append go-dir
- (file-sans-extension file)
- ".go")))
- ;; Install source module.
- (install-file (string-append source-directory "/" file)
- (string-append module-dir
- "/" (dirname file)))
-
- ;; Install and compile module.
- (apply invoke guild "compile" "-L" source-directory
- "-o" go
- (string-append source-directory "/" file)
- flags)))
-
- ;; Arrange to strip SOURCE-DIRECTORY from file names.
- (with-directory-excursion source-directory
- (find-files "." scheme-file-regexp)))
+
+ (let ((source-files
+ (with-directory-excursion source-directory
+ (find-files "." scheme-file-regexp))))
+ (invoke-each
+ (map (lambda (file)
+ (cons* guild
+ "guild" "compile"
+ "-L" source-directory
+ "-o" (string-append go-dir
+ (file-sans-extension file)
+ ".go")
+ (string-append source-directory "/" file)
+ flags))
+ source-files)
+ #:max-processes (parallel-job-count)
+ #:report-progress report-build-progress)
+
+ (for-each
+ (lambda (file)
+ (install-file (string-append source-directory "/" file)
+ (string-append module-dir
+ "/" (dirname file))))
+ source-files))
#t))
(define* (install-documentation #:key outputs
--
2.21.0
next prev parent reply other threads:[~2019-04-16 18:14 UTC|newest]
Thread overview: 9+ messages / expand[flat|nested] mbox.gz Atom feed top
2019-03-24 21:23 [bug#34982] [PATCH] guile-build-system: Support building in parallel Christopher Baines
2019-03-30 10:56 ` Ludovic Courtès
2019-04-05 23:33 ` Christopher Baines
2019-04-05 23:50 ` [bug#34982] " Christopher Baines
2019-04-16 17:06 ` Ludovic Courtès
2019-04-16 18:25 ` Christopher Baines
2019-04-16 18:13 ` Christopher Baines [this message]
2019-04-16 19:30 ` Ludovic Courtès
2019-04-19 7:43 ` bug#34982: " Christopher Baines
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20190416181326.2416-1-mail@cbaines.net \
--to=mail@cbaines.net \
--cc=34982@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.