From b50c5b741891eabb16b83091d911c6ebd9b890d3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 5 Sep 2014 23:11:04 +0200 Subject: 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'. --- guix/build/pull.scm | 77 ++++++++++++++++++++++++++++++++++++--------------- guix/scripts/pull.scm | 19 +++++++------ 2 files changed, 65 insertions(+), 31 deletions(-) (limited to 'guix') diff --git a/guix/build/pull.scm b/guix/build/pull.scm index e5b8797503..841787f0bb 100644 --- a/guix/build/pull.scm +++ b/guix/build/pull.scm @@ -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 diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index c2bf536e86..5dafb84f91 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -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)) -- cgit v1.2.3