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.

3 files changed, 196 insertions, 78 deletions

diff --git a/guix/build/compile.scm b/guix/build/compile.scm
new file mode 100644
index 0000000000..6f15ba5789
--- /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 <ludo@gnu.org>
+;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+;;;
+;;; 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 1ae35ab382..6f7aa27868 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 2741725b9d..c861614b8a 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))