;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com> ;;; Copyright © 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; 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/>. (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-mtime<? f1 f2) (< (stat:mtime (stat f1)) (stat:mtime (stat f2)))) (define (scm->go 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-mtime<? go file)))) (define* (parallel-job-count #:optional (flags (getenv "MAKEFLAGS"))) "Return the number of parallel jobs as determined by FLAGS, the flags passed to 'make'." (match flags (#f (current-processor-count)) (flags (let ((initial-flags (string-tokenize flags))) (let loop ((flags initial-flags)) (match flags (() ;; Note: GNU make prior to version 4.2 would hide "-j" flags from ;; $MAKEFLAGS. Thus, check for a "--jobserver" flag here and ;; assume we're using all cores if specified. (if (any (lambda (flag) (string-prefix? "--jobserver" flag)) initial-flags) (current-processor-count) ;GNU make < 4.2 1)) ;sequential make (("-j" (= string->number 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 (parallel-job-count*) ;; XXX: Work around memory requirements not sustainable on i686 above '-j4' ;; or so: <https://bugs.gnu.org/40522>. (let ((count (parallel-job-count))) (if (string-prefix? "i686" %host-type) (min count 4) count))) (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)))))))))