diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | build-aux/compile-all.scm | 92 | ||||
| -rw-r--r-- | guix/build/compile.scm | 165 | ||||
| -rw-r--r-- | guix/build/pull.scm | 105 | ||||
| -rw-r--r-- | guix/discovery.scm | 4 |
5 files changed, 209 insertions, 158 deletions
diff --git a/Makefile.am b/Makefile.am index 2855b4efdd..fd6f9729c9 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 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))))))) 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)) |