;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2016, 2017, 2018 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 modules) #: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 (relative-file directory file) "Return FILE relative to DIRECTORY, if possible." (if (string-prefix? (string-append directory "/") file) (string-drop file (+ 1 (string-length directory))) file)) (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 ...) (let ((file (relative-file directory file))) (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 (call/exit-on-exception thunk) "Evaluate THUNK and exit right away if an exception is thrown." (catch #t thunk (const #f) (lambda (key . args) (false-if-exception ;; Duplicate stderr to avoid thread-safety issues. (let* ((port (duplicate-port (current-error-port) "w0")) (stack (make-stack #t)) (depth (stack-length stack)) (frame (and (> depth 1) (stack-ref stack 1)))) (false-if-exception (display-backtrace stack port)) (print-exception port frame key args))) ;; Don't go any further. (primitive-exit 1)))) (define-syntax-rule (exit-on-exception exp ...) "Evaluate EXP and exit if an exception is thrown." (call/exit-on-exception (lambda () exp ...))) (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)) ;; Exit as soon as something goes wrong. (exit-on-exception (with-fluids ((*current-warning-prefix* "")) (with-target host (lambda () (let ((relative (relative-file source-directory file))) (compile-file file #:output-file (string-append build-directory "/" (scm->go relative)) #:opts (append warning-options (optimization-options relative)))))))) (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) ;; XXX: Don't use too many workers to work around the insane memory ;; requirements of the compiler in Guile 2.2.2: ;; <https://lists.gnu.org/archive/html/guile-devel/2017-05/msg00033.html>. (n-par-for-each (min workers 8) build files) (unless (zero? total) (report-compilation #f total total))))) (eval-when (eval load) (when (and (string=? "2" (major-version)) (or (string=? "0" (minor-version)) (and (string=? (minor-version) "2") (< (string->number (micro-version)) 4)))) ;; Work around <https://bugs.gnu.org/31878> on Guile < 2.2.4. ;; Serialize 'try-module-autoload' calls. (set! (@ (guile) try-module-autoload) (let ((mutex (make-mutex 'recursive)) (real (@ (guile) try-module-autoload))) (lambda* (module #:optional version) (with-mutex mutex (real module version))))))) ;;; Local Variables: ;;; eval: (put 'with-augmented-search-path 'scheme-indent-function 2) ;;; eval: (put 'with-target 'scheme-indent-function 1) ;;; End: