From 2890ad332fcdfd4bc92b127d783975437c8b718b Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 13 Oct 2017 18:07:41 +0200
Subject: 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.
---
 build-aux/compile-all.scm | 92 +++++++----------------------------------------
 1 file changed, 12 insertions(+), 80 deletions(-)

(limited to 'build-aux')

diff --git a/build-aux/compile-all.scm b/build-aux/compile-all.scm
index fe25c5d065..2fc3102daa 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)))))))
-- 
cgit v1.2.3