Toggle diff (451 lines)
diff --git a/Makefile.am b/Makefile.am
index 2855b4efd..fd6f9729c 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 fe25c5d06..2fc3102da 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 000000000..6f15ba578
--- /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 1ae35ab38..6f7aa2786 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 2741725b9..c861614b8 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))
--
2.14.2
