pull: Add a compilation progress report.

* guix/build/pull.scm (report-build-progress): New procedure.
  (p-for-each): Add #:progress parameter.
  [loop]: Keep track of the number of completed processes.  Tail-call
  PROGRESS at each loop iteration.
  (build-guix): Add #:debug-port parameter.  Use it for verbose
  messages.  Change 'tar' flags to 'xf'.  Around 'compile-file' call,
  bind CURRENT-WARNING-PORT to DEBUG-PORT.
* guix/scripts/pull.scm (unpack): Add #:verbose? parameter.
  [builder]: Pass #:debug-port to 'build-guix'.
  (guix-pull): Leave CURRENT-BUILD-OUTPUT-PORT unchanged.  Pass
  #:verbose? to 'unpack'.
This commit is contained in:
Ludovic Courtès 2014-09-05 23:11:04 +02:00
parent 6fd1a79674
commit b50c5b7418
2 changed files with 65 additions and 31 deletions

View File

@ -21,6 +21,7 @@
#:use-module (system base compile)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
@ -47,43 +48,70 @@ normally, and 1 if an exception is raised."
(pid
#t)))
(define* (report-build-progress total completed cont
#:optional (log-port (current-error-port)))
"Report that COMPLETED out of TOTAL files have been completed, and call
CONT."
(display #\cr log-port)
(format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n
(* 100. (/ completed total)) total)
(force-output log-port)
(cont))
(define* (p-for-each proc lst
#:optional (max-processes (current-processor-count)))
#:optional (max-processes (current-processor-count))
#:key (progress report-build-progress))
"Invoke PROC for each element of LST in a separate process, using up to
MAX-PROCESSES processes in parallel. Raise an error if one of the processes
exit with non-zero."
MAX-PROCESSES processes in parallel. Call PROGRESS at each step, passing it
the continuation. Raise an error if one of the processes exit with non-zero."
(define total
(length lst))
(define (wait-for-one-process)
(match (waitpid WAIT_ANY)
((_ . status)
(unless (zero? (status:exit-val status))
(error "process failed" proc status)))))
(let loop ((lst lst)
(running 0))
(let loop ((lst lst)
(running 0)
(completed 0))
(match lst
(()
(or (zero? running)
(begin
(let ((running (- running 1))
(completed (+ completed 1)))
(wait-for-one-process)
(loop lst (- running 1)))))
(progress total completed
(lambda ()
(loop lst running completed))))))
((head . tail)
(if (< running max-processes)
(begin
(let ((running (+ 1 running)))
(call-with-process (cut proc head))
(loop tail (+ running 1)))
(begin
(progress total completed
(lambda ()
(loop tail running completed))))
(let ((running (- running 1))
(completed (+ completed 1)))
(wait-for-one-process)
(loop lst (- running 1))))))))
(progress total completed
(lambda ()
(loop lst running completed)))))))))
(define* (build-guix out tarball
#:key tar gzip gcrypt)
"Build and install Guix in directory OUT using source from TARBALL."
#:key tar gzip gcrypt
(debug-port (%make-void-port "w")))
"Build and install Guix in directory OUT using source from TARBALL. Write
any debugging output to DEBUG-PORT."
(setvbuf (current-output-port) _IOLBF)
(setvbuf (current-error-port) _IOLBF)
(setenv "PATH" (string-append tar "/bin:" gzip "/bin"))
(system* "tar" "xvf" tarball)
(format debug-port "extracting '~a'...~%" tarball)
(system* "tar" "xf" tarball)
(match (scandir "." (lambda (name)
(and (not (member name '("." "..")))
(file-is-directory? name))))
@ -92,11 +120,13 @@ exit with non-zero."
(x
(error "tarball did not produce a single source directory" x)))
(format #t "copying and compiling Guix to `~a'...~%" out)
(format #t "copying and compiling to '~a'...~%" out)
;; Copy everything under guix/ and gnu/ plus {guix,gnu}.scm.
(copy-recursively "guix" (string-append out "/guix"))
(copy-recursively "gnu" (string-append out "/gnu"))
(copy-recursively "guix" (string-append out "/guix")
#:log debug-port)
(copy-recursively "gnu" (string-append out "/gnu")
#:log debug-port)
(copy-file "guix.scm" (string-append out "/guix.scm"))
(copy-file "gnu.scm" (string-append out "/gnu.scm"))
@ -121,12 +151,12 @@ exit with non-zero."
(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)))
(format debug-port "~%compiling '~a'...~%" file)
(parameterize ((current-warning-port debug-port))
(compile-file file
#:output-file go
#:opts
%auto-compilation-options))))
(filter (cut string-suffix? ".scm" <>)
@ -144,6 +174,7 @@ exit with non-zero."
(delete-file (string-append out "/guix/config.scm"))
(delete-file (string-append out "/guix/config.go"))
(newline)
#t)
;;; pull.scm ends here

View File

@ -38,15 +38,21 @@
"http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz"
)
(define (unpack store tarball)
(define* (unpack store tarball #:key verbose?)
"Return a derivation that unpacks TARBALL into STORE and compiles Scheme
files."
(define builder
'(begin
`(begin
(use-modules (guix build pull))
(build-guix (assoc-ref %outputs "out")
(assoc-ref %build-inputs "tarball")
;; XXX: This is not perfect, enabling VERBOSE? means
;; building a different derivation.
#:debug-port (if ',verbose?
(current-error-port)
(%make-void-port "w"))
#:tar (assoc-ref %build-inputs "tar")
#:gzip (assoc-ref %build-inputs "gzip")
#:gcrypt (assoc-ref %build-inputs "gcrypt"))))
@ -129,13 +135,10 @@ Download and deploy the latest version of Guix.\n"))
(package-derivation store
(if (assoc-ref opts 'bootstrap?)
%bootstrap-guile
(canonical-package guile-2.0))))
(current-build-output-port
(if (assoc-ref opts 'verbose?)
(current-error-port)
(%make-void-port "w"))))
(canonical-package guile-2.0)))))
(let* ((config-dir (config-directory))
(source (unpack store tarball))
(source (unpack store tarball
#:verbose? (assoc-ref opts 'verbose?)))
(source-dir (derivation->output-path source)))
(if (show-what-to-build store (list source))
(if (build-derivations store (list source))