ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

build: Factorize module compilation in (guix build compile).

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2017-10-13 18:07:41 +02:00
parent 6e644cfdb3
commit 2890ad332f
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
5 changed files with 209 additions and 158 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
Makefile.am
View file

@ -133,6 +133,7 @@ MODULES = \
guix/build/utils.scm \ guix/build/utils.scm \
guix/build/union.scm \ guix/build/union.scm \
guix/build/profiles.scm \ guix/build/profiles.scm \
guix/build/compile.scm \
guix/build/pull.scm \ guix/build/pull.scm \
guix/build/rpath.scm \ guix/build/rpath.scm \
guix/build/cvs.scm \ guix/build/cvs.scm \

92
build-aux/compile-all.scm
View file

@ -17,21 +17,12 @@
;;; You should have received a copy of the GNU General Public License ;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(use-modules (system base target) (use-modules (ice-9 match)
(system base message)
(ice-9 match)
(ice-9 threads) (ice-9 threads)
(guix build compile)
(guix build utils)) (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 host (getenv "host"))
(define srcdir (getenv "srcdir")) (define srcdir (getenv "srcdir"))
(define (relative-file file) (define (relative-file file)
@ -53,62 +44,6 @@ (define (file-needs-compilation? file)
(or (not (file-exists? go)) (or (not (file-exists? go))
(file-mtime<? go file)))) (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 ;; Install a SIGINT handler to give unwind handlers in 'compile-file' an
;; opportunity to run upon SIGINT and to remove temporary output files. ;; opportunity to run upon SIGINT and to remove temporary output files.
(sigaction SIGINT (sigaction SIGINT
@ -117,16 +52,13 @@ (define (compile-file* file output-mutex)
(match (command-line) (match (command-line)
((_ . files) ((_ . files)
(let ((files (filter file-needs-compilation? files))) (compile-files srcdir (getcwd)
(for-each load-module-file files) (filter file-needs-compilation? files)
(let ((mutex (make-mutex))) #:host host
;; Make sure compilation related modules are loaded before starting to #:report-load (lambda (file total completed)
;; compile files in parallel. (when file
(compile #f) (format #t " LOAD ~a~%" file)))
(par-for-each (lambda (file) #:report-compilation (lambda (file total completed)
(compile-file* file mutex)) (when file
files))))) (format #t " GUILEC ~a~%"
(scm->go file)))))))
;;; Local Variables:
;;; eval: (put 'with-target 'scheme-indent-function 1)
;;; End:

165
guix/build/compile.scm Normal file
View file

@ -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:

91
guix/build/pull.scm
View file

@ -20,11 +20,10 @@
(define-module (guix build pull) (define-module (guix build pull)
#:use-module (guix modules) #:use-module (guix modules)
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (system base compile) #:use-module (guix build compile)
#:use-module (ice-9 ftw) #:use-module (ice-9 ftw)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:use-module (ice-9 threads)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
@ -63,34 +62,6 @@ (define (all-scheme-files directory)
(string-prefix? gnu b)) (string-prefix? gnu b))
(string<? a 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 (define* (build-guix out source
#:key #:key
@ -148,53 +119,33 @@ (define* (build-guix out source
(set! %load-path (cons out %load-path)) (set! %load-path (cons out %load-path))
(set! %load-compiled-path (cons out %load-compiled-path)) (set! %load-compiled-path (cons out %load-compiled-path))
;; Compile the .scm files. Load all the files before compiling them to ;; Compile the .scm files. Filter out files depending on Guile-SSH when
;; work around <http://bugs.gnu.org/15602> (FIXME). ;; Guile-SSH is missing.
;; Filter out files depending on Guile-SSH when Guile-SSH is missing. (let ((files (filter has-all-its-dependencies?
(let* ((files (filter has-all-its-dependencies? (all-scheme-files out))))
(all-scheme-files out))) (compile-files out out files
(total (length files)))
(let loop ((files files) #:workers (parallel-job-count)
(completed 0))
(match files ;; Disable warnings.
(() *unspecified*) #:warning-options '()
((file . files)
#:report-load
(lambda (file total completed)
(display #\cr log-port) (display #\cr log-port)
(format log-port "loading...\t~5,1f% of ~d files" ;FIXME: i18n (format log-port
"loading...\t~5,1f% of ~d files" ;FIXME: i18n
(* 100. (/ completed total)) total) (* 100. (/ completed total)) total)
(force-output log-port) (force-output log-port)
(format debug-port "~%loading '~a'...~%" file) (format debug-port "~%loading '~a'...~%" file))
;; Turn "<out>/foo/bar.scm" into (foo bar).
(let* ((relative-file (string-drop file (+ (string-length out) 1))) #:report-compilation
(module-path (string-drop-right relative-file 4)) (lambda (file total completed)
(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) (display #\cr log-port)
(format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n (format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n
(* 100. (/ completed total)) total) (* 100. (/ completed total)) total)
(force-output log-port) (force-output log-port)
(format debug-port "~%compiling '~a'...~%" file)) (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))))
(newline) (newline)
#t) #t)

4
guix/discovery.scm
View file

@ -24,7 +24,9 @@ (define-module (guix discovery)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
#:use-module (ice-9 ftw) #:use-module (ice-9 ftw)
#:export (scheme-modules #:export (file-name->module-name
scheme-modules
fold-modules fold-modules
all-modules all-modules
fold-module-public-variables)) fold-module-public-variables))