02/06: build: Factorize module compilation in (guix build compile).

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 2890ad332fcdfd4bc92b127d783975437c8b718b
Author: Ludovic Courtès <address@hidden>
Date:   Fri Oct 13 18:07:41 2017 +0200

    build: Factorize module compilation in (guix build compile).
    
    * guix/build/compile.scm: New file.
    * Makefile.am (MODULES): Add it.
    * build-aux/compile-all.scm: Use it.
    (warnings, file->module, load-module-file)
    (%default-optimizations, %lightweight-optimizations)
    (optimization-options, compile-file*): Remove.
    <top level>: Use 'compile-files'.
    * guix/build/pull.scm (%default-optimizations)
    (%lightweight-optimizations, optimization-options): Remove.
    (build-guix): Rewrite as a call to 'compile-files'.
    * guix/discovery.scm (file-name->module-name): Export.
---
 Makefile.am               |   1 +
 build-aux/compile-all.scm |  92 ++++----------------------
 guix/build/compile.scm    | 165 ++++++++++++++++++++++++++++++++++++++++++++++
 guix/build/pull.scm       | 105 ++++++++---------------------
 guix/discovery.scm        |   4 +-
 5 files changed, 209 insertions(+), 158 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 2855b4e..fd6f972 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -133,6 +133,7 @@ MODULES =                                   \
   guix/build/utils.scm                         \
   guix/build/union.scm                         \
   guix/build/profiles.scm                      \
+  guix/build/compile.scm                       \
   guix/build/pull.scm                          \
   guix/build/rpath.scm                         \
   guix/build/cvs.scm                           \
diff --git a/build-aux/compile-all.scm b/build-aux/compile-all.scm
index fe25c5d..2fc3102 100644
--- a/build-aux/compile-all.scm
+++ b/build-aux/compile-all.scm
@@ -17,21 +17,12 @@
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
-(use-modules (system base target)
-             (system base message)
-             (ice-9 match)
+(use-modules (ice-9 match)
              (ice-9 threads)
+             (guix build compile)
              (guix build utils))
 
-(define warnings
-  ;; FIXME: 'format' is missing because it reports "non-literal format
-  ;; strings" due to the fact that we use 'G_' instead of '_'.  We'll need
-  ;; help from Guile to solve this.
-  '(unsupported-warning unbound-variable arity-mismatch
-    macro-use-before-definition))                 ;new in 2.2
-
 (define host (getenv "host"))
-
 (define srcdir (getenv "srcdir"))
 
 (define (relative-file file)
@@ -53,62 +44,6 @@
     (or (not (file-exists? go))
         (file-mtime<? go file))))
 
-(define (file->module file)
-  (let* ((relative (relative-file file))
-         (module-path (string-drop-right relative 4)))
-    (map string->symbol
-         (string-split module-path #\/))))
-
-;;; To work around <http://bugs.gnu.org/15602> (FIXME), we want to load all
-;;; files to be compiled first.  We do this via resolve-interface so that the
-;;; top-level of each file (module) is only executed once.
-(define (load-module-file file)
-  (let ((module (file->module file)))
-    (format #t "  LOAD     ~a~%" module)
-    (resolve-interface module)))
-
-(cond-expand
-  (guile-2.2 (use-modules (language tree-il optimize)
-                          (language cps optimize)))
-  (else #f))
-
-(define %default-optimizations
-  ;; Default optimization options (equivalent to -O2 on Guile 2.2).
-  (cond-expand
-    (guile-2.2 (append (tree-il-default-optimization-options)
-                       (cps-default-optimization-options)))
-    (else '())))
-
-(define %lightweight-optimizations
-  ;; Lightweight optimizations (like -O0, but with partial evaluation).
-  (let loop ((opts %default-optimizations)
-             (result '()))
-    (match opts
-      (() (reverse result))
-      ((#:partial-eval? _ rest ...)
-       (loop rest `(#t #:partial-eval? ,@result)))
-      ((kw _ rest ...)
-       (loop rest `(#f ,kw ,@result))))))
-
-(define (optimization-options file)
-  (if (string-contains file "gnu/packages/")
-      %lightweight-optimizations                  ;build faster
-      '()))
-
-(define (compile-file* file output-mutex)
-  (let ((go (scm->go file)))
-    (with-mutex output-mutex
-      (format #t "  GUILEC   ~a~%" go)
-      (force-output))
-    (mkdir-p (dirname go))
-    (with-fluids ((*current-warning-prefix* ""))
-      (with-target host
-        (lambda ()
-          (compile-file file
-                        #:output-file go
-                        #:opts `(#:warnings ,warnings
-                                 ,@(optimization-options file))))))))
-
 ;; Install a SIGINT handler to give unwind handlers in 'compile-file' an
 ;; opportunity to run upon SIGINT and to remove temporary output files.
 (sigaction SIGINT
@@ -117,16 +52,13 @@
 
 (match (command-line)
   ((_ . files)
-   (let ((files (filter file-needs-compilation? files)))
-     (for-each load-module-file files)
-     (let ((mutex (make-mutex)))
-       ;; Make sure compilation related modules are loaded before starting to
-       ;; compile files in parallel.
-       (compile #f)
-       (par-for-each (lambda (file)
-                       (compile-file* file mutex))
-                     files)))))
-
-;;; Local Variables:
-;;; eval: (put 'with-target 'scheme-indent-function 1)
-;;; End:
+   (compile-files srcdir (getcwd)
+                  (filter file-needs-compilation? files)
+                  #:host host
+                  #:report-load (lambda (file total completed)
+                                  (when file
+                                    (format #t "  LOAD     ~a~%" file)))
+                  #:report-compilation (lambda (file total completed)
+                                         (when file
+                                           (format #t "  GUILEC   ~a~%"
+                                                   (scm->go file)))))))
diff --git a/guix/build/compile.scm b/guix/build/compile.scm
new file mode 100644
index 0000000..6f15ba5
--- /dev/null
+++ b/guix/build/compile.scm
@@ -0,0 +1,165 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014, 2016, 2017 Ludovic Courtès <address@hidden>
+;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build compile)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 threads)
+  #:use-module (system base target)
+  #:use-module (system base compile)
+  #:use-module (system base message)
+  #:use-module (guix discovery)
+  #:use-module (guix build utils)
+  #:export (%default-optimizations
+            %lightweight-optimizations
+            compile-files))
+
+;;; Commentary:
+;;;
+;;; Support code to compile Guile code as efficiently as possible (both with
+;;; Guile 2.0 and 2.2).
+;;;
+;;; Code:
+
+(cond-expand
+  (guile-2.2 (use-modules (language tree-il optimize)
+                          (language cps optimize)))
+  (else #f))
+
+(define %default-optimizations
+  ;; Default optimization options (equivalent to -O2 on Guile 2.2).
+  (cond-expand
+    (guile-2.2 (append (tree-il-default-optimization-options)
+                       (cps-default-optimization-options)))
+    (else '())))
+
+(define %lightweight-optimizations
+  ;; Lightweight optimizations (like -O0, but with partial evaluation).
+  (let loop ((opts %default-optimizations)
+             (result '()))
+    (match opts
+      (() (reverse result))
+      ((#:partial-eval? _ rest ...)
+       (loop rest `(#t #:partial-eval? ,@result)))
+      ((kw _ rest ...)
+       (loop rest `(#f ,kw ,@result))))))
+
+(define %warnings
+  ;; FIXME: 'format' is missing because it reports "non-literal format
+  ;; strings" due to the fact that we use 'G_' instead of '_'.  We'll need
+  ;; help from Guile to solve this.
+  '(unsupported-warning unbound-variable arity-mismatch
+    macro-use-before-definition))                 ;new in 2.2
+
+(define (optimization-options file)
+  "Return the default set of optimizations options for FILE."
+  (if (string-contains file "gnu/packages/")
+      %lightweight-optimizations                  ;build faster
+      '()))
+
+(define (scm->go file)
+  "Strip the \".scm\" suffix from FILE, and append \".go\"."
+  (string-append (string-drop-right file 4) ".go"))
+
+(define* (load-files directory files
+                     #:key
+                     (report-load (const #f))
+                     (debug-port (%make-void-port "w")))
+  "Load FILES, a list of relative file names, from DIRECTORY."
+  (define total
+    (length files))
+
+  (let loop ((files files)
+             (completed 0))
+    (match files
+      (()
+       (unless (zero? total)
+         (report-load #f total completed))
+       *unspecified*)
+      ((file files ...)
+       (report-load file total completed)
+       (format debug-port "~%loading '~a'...~%" file)
+
+       (parameterize ((current-warning-port debug-port))
+         (resolve-interface (file-name->module-name file)))
+
+       (loop files (+ 1 completed))))))
+
+(define-syntax-rule (with-augmented-search-path path item body ...)
+  "Within the dynamic extent of BODY, augment PATH by adding ITEM to the
+front."
+  (let ((initial-value path))
+    (dynamic-wind
+      (lambda ()
+        (set! path (cons item path)))
+      (lambda ()
+        body ...)
+      (lambda ()
+        (set! path initial-value)))))
+
+(define* (compile-files source-directory build-directory files
+                        #:key
+                        (host %host-type)
+                        (workers (current-processor-count))
+                        (optimization-options optimization-options)
+                        (warning-options `(#:warnings ,%warnings))
+                        (report-load (const #f))
+                        (report-compilation (const #f))
+                        (debug-port (%make-void-port "w")))
+  "Compile FILES, a list of source files taken from SOURCE-DIRECTORY, to
+BUILD-DIRECTORY, using up to WORKERS parallel workers.  The resulting object
+files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"."
+  (define progress-lock (make-mutex))
+  (define total (length files))
+  (define completed 0)
+
+  (define (build file)
+    (with-mutex progress-lock
+      (report-compilation file total completed))
+    (with-fluids ((*current-warning-prefix* ""))
+      (with-target host
+        (lambda ()
+          (compile-file file
+                        #:output-file (string-append build-directory "/"
+                                                     (scm->go file))
+                        #:opts (append warning-options
+                                       (optimization-options file))))))
+    (with-mutex progress-lock
+      (set! completed (+ 1 completed))))
+
+  (with-augmented-search-path %load-path source-directory
+    (with-augmented-search-path %load-compiled-path build-directory
+      ;; FIXME: To work around <https://bugs.gnu.org/15602>, we first load all
+      ;; of FILES.
+      (load-files source-directory files
+                  #:report-load report-load
+                  #:debug-port debug-port)
+
+      ;; Make sure compilation related modules are loaded before starting to
+      ;; compile files in parallel.
+      (compile #f)
+
+      (n-par-for-each workers build files)
+      (unless (zero? total)
+        (report-compilation #f total total)))))
+
+;;; Local Variables:
+;;; eval: (put 'with-augmented-search-path 'scheme-indent-function 2)
+;;; eval: (put 'with-target 'scheme-indent-function 1)
+;;; End:
diff --git a/guix/build/pull.scm b/guix/build/pull.scm
index 1ae35ab..6f7aa27 100644
--- a/guix/build/pull.scm
+++ b/guix/build/pull.scm
@@ -20,11 +20,10 @@
 (define-module (guix build pull)
   #:use-module (guix modules)
   #:use-module (guix build utils)
-  #:use-module (system base compile)
+  #:use-module (guix build compile)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
-  #:use-module (ice-9 threads)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
@@ -63,34 +62,6 @@ available, false otherwise."
                      (string-prefix? gnu  b))
                 (string<? a b))))))
 
-(cond-expand
-  (guile-2.2 (use-modules (language tree-il optimize)
-                          (language cps optimize)))
-  (else #f))
-
-(define %default-optimizations
-  ;; Default optimization options (equivalent to -O2 on Guile 2.2).
-  (cond-expand
-    (guile-2.2 (append (tree-il-default-optimization-options)
-                       (cps-default-optimization-options)))
-    (else '())))
-
-(define %lightweight-optimizations
-  ;; Lightweight optimizations (like -O0, but with partial evaluation).
-  (let loop ((opts %default-optimizations)
-             (result '()))
-    (match opts
-      (() (reverse result))
-      ((#:partial-eval? _ rest ...)
-       (loop rest `(#t #:partial-eval? ,@result)))
-      ((kw _ rest ...)
-       (loop rest `(#f ,kw ,@result))))))
-
-(define (optimization-options file)
-  (if (string-contains file "gnu/packages/")
-      %lightweight-optimizations                  ;build faster
-      '()))
-
 
 (define* (build-guix out source
                      #:key
@@ -148,53 +119,33 @@ containing the source code.  Write any debugging output 
to DEBUG-PORT."
     (set! %load-path (cons out %load-path))
     (set! %load-compiled-path (cons out %load-compiled-path))
 
-    ;; Compile the .scm files.  Load all the files before compiling them to
-    ;; work around <http://bugs.gnu.org/15602> (FIXME).
-    ;; Filter out files depending on Guile-SSH when Guile-SSH is missing.
-    (let* ((files (filter has-all-its-dependencies?
-                          (all-scheme-files out)))
-           (total (length files)))
-      (let loop ((files files)
-                 (completed 0))
-        (match files
-          (() *unspecified*)
-          ((file . files)
-           (display #\cr log-port)
-           (format log-port "loading...\t~5,1f% of ~d files" ;FIXME: i18n
-                   (* 100. (/ completed total)) total)
-           (force-output log-port)
-           (format debug-port "~%loading '~a'...~%" file)
-           ;; Turn "<out>/foo/bar.scm" into (foo bar).
-           (let* ((relative-file (string-drop file (+ (string-length out) 1)))
-                  (module-path (string-drop-right relative-file 4))
-                  (module-name (map string->symbol
-                                    (string-split module-path #\/))))
-             (parameterize ((current-warning-port debug-port))
-               (resolve-interface module-name)))
-           (loop files (+ 1 completed)))))
-      (newline)
-      (let ((mutex (make-mutex))
-            (completed 0))
-        ;; Make sure compilation related modules are loaded before starting to
-        ;; compile files in parallel.
-        (compile #f)
-        (n-par-for-each
-         (parallel-job-count)
-         (lambda (file)
-           (with-mutex mutex
-             (display #\cr log-port)
-             (format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n
-                     (* 100. (/ completed total)) total)
-             (force-output log-port)
-             (format debug-port "~%compiling '~a'...~%" file))
-           (let ((go (string-append (string-drop-right file 4) ".go")))
-             (parameterize ((current-warning-port (%make-void-port "w")))
-               (compile-file file
-                             #:output-file go
-                             #:opts (optimization-options file))))
-           (with-mutex mutex
-             (set! completed (+ 1 completed))))
-         files))))
+    ;; Compile the .scm files.  Filter out files depending on Guile-SSH when
+    ;; Guile-SSH is missing.
+    (let ((files (filter has-all-its-dependencies?
+                         (all-scheme-files out))))
+      (compile-files out out files
+
+                     #:workers (parallel-job-count)
+
+                     ;; Disable warnings.
+                     #:warning-options '()
+
+                     #:report-load
+                     (lambda (file total completed)
+                       (display #\cr log-port)
+                       (format log-port
+                               "loading...\t~5,1f% of ~d files" ;FIXME: i18n
+                               (* 100. (/ completed total)) total)
+                       (force-output log-port)
+                       (format debug-port "~%loading '~a'...~%" file))
+
+                     #:report-compilation
+                     (lambda (file total 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)
+                       (format debug-port "~%compiling '~a'...~%" file)))))
 
   (newline)
   #t)
diff --git a/guix/discovery.scm b/guix/discovery.scm
index 2741725..c861614 100644
--- a/guix/discovery.scm
+++ b/guix/discovery.scm
@@ -24,7 +24,9 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 ftw)
-  #:export (scheme-modules
+  #:export (file-name->module-name
+
+            scheme-modules
             fold-modules
             all-modules
             fold-module-public-variables))