X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/58366883f2f1516a4a02f5b4e2a70e86481827b5..f78f0d7ffee6a51d997705038842b3f8341bfa4b:/build-aux/compile-all.scm diff --git a/build-aux/compile-all.scm b/build-aux/compile-all.scm dissimilarity index 61% index fe25c5d065..e9f3e957d9 100644 --- a/build-aux/compile-all.scm +++ b/build-aux/compile-all.scm @@ -1,132 +1,135 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Taylan Ulrich Bayırlı/Kammer -;;; Copyright © 2016, 2017 Ludovic Courtès -;;; -;;; 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 . - -(use-modules (system base target) - (system base message) - (ice-9 match) - (ice-9 threads) - (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) - (if (string-prefix? (string-append srcdir "/") file) - (string-drop file (+ 1 (string-length srcdir))) - file)) - -(define (file-mtimego file) - (let* ((relative (relative-file file)) - (without-extension (string-drop-right relative 4))) - (string-append without-extension ".go"))) - -(define (file-needs-compilation? file) - (let ((go (scm->go file))) - (or (not (file-exists? go)) - (file-mtimemodule file) - (let* ((relative (relative-file file)) - (module-path (string-drop-right relative 4))) - (map string->symbol - (string-split module-path #\/)))) - -;;; To work around (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 - (lambda args - (exit 1))) - -(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: +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Taylan Ulrich Bayırlı/Kammer +;;; Copyright © 2016, 2017, 2019 Ludovic Courtès +;;; +;;; 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 . + +(use-modules (ice-9 format) + (ice-9 match) + (ice-9 threads) + (srfi srfi-1) + (guix build compile) + (guix build utils)) + +(define host (getenv "host")) +(define srcdir (getenv "srcdir")) + +(define (relative-file file) + (if (string-prefix? (string-append srcdir "/") file) + (string-drop file (+ 1 (string-length srcdir))) + file)) + +(define (file-mtimego file) + (let* ((relative (relative-file file)) + (without-extension (string-drop-right relative 4))) + (string-append without-extension ".go"))) + +(define (file-needs-compilation? file) + (let ((go (scm->go file))) + (or (not (file-exists? go)) + (file-mtimenumber count) _ ...) + (if (integer? count) + count + (current-processor-count))) + ((head tail ...) + (if (string-prefix? "-j" head) + (match (string-drop head 2) + ("" + (current-processor-count)) + ((= string->number count) + (if (integer? count) + count + (current-processor-count)))) + (loop tail))))))))) + +(define (% completed total) + "Return the completion percentage of COMPLETED over TOTAL as an integer." + (inexact->exact (round (* 100. (/ completed total))))) + +;; 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 + (lambda args + (exit 1))) + +(match (command-line) + ((_ . files) + (catch #t + (lambda () + (compile-files srcdir (getcwd) + (filter file-needs-compilation? files) + #:workers (parallel-job-count) + #:host host + #:report-load (lambda (file total completed) + (when file + (format #t "[~3d%] LOAD ~a~%" + (% (+ 1 completed) (* 2 total)) + file) + (force-output))) + #:report-compilation (lambda (file total completed) + (when file + (format #t "[~3d%] GUILEC ~a~%" + (% (+ total completed 1) + (* 2 total)) + (scm->go file)) + (force-output))))) + (lambda _ + (primitive-exit 1)) + (lambda args + ;; Try to report the error in an intelligible way. + (let* ((stack (make-stack #t)) + (frame (if (> (stack-length stack) 1) + (stack-ref stack 1) ;skip the 'throw' frame + (stack-ref stack 0))) + (ui (false-if-exception + (resolve-module '(guix ui)))) + (report (and ui + (false-if-exception + (module-ref ui 'report-load-error))))) + (if report + ;; In Guile <= 2.2.5, 'current-load-port' was not exported. + (let ((load-port ((module-ref (resolve-module '(ice-9 ports)) + 'current-load-port)))) + (report (or (and=> load-port port-filename) "?.scm") + args frame)) + (begin + (print-exception (current-error-port) frame + (car args) (cdr args)) + (display-backtrace stack (current-error-port)))))))))