| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2016 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com> |
| 3 | ;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> |
| 4 | ;;; |
| 5 | ;;; This file is part of GNU Guix. |
| 6 | ;;; |
| 7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
| 8 | ;;; under the terms of the GNU General Public License as published by |
| 9 | ;;; the Free Software Foundation; either version 3 of the License, or (at |
| 10 | ;;; your option) any later version. |
| 11 | ;;; |
| 12 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
| 13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
| 14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 15 | ;;; GNU General Public License for more details. |
| 16 | ;;; |
| 17 | ;;; You should have received a copy of the GNU General Public License |
| 18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
| 19 | |
| 20 | (use-modules (ice-9 format) |
| 21 | (ice-9 match) |
| 22 | (ice-9 threads) |
| 23 | (srfi srfi-1) |
| 24 | (guix build compile) |
| 25 | (guix build utils)) |
| 26 | |
| 27 | (define host (getenv "host")) |
| 28 | (define srcdir (getenv "srcdir")) |
| 29 | |
| 30 | (define (relative-file file) |
| 31 | (if (string-prefix? (string-append srcdir "/") file) |
| 32 | (string-drop file (+ 1 (string-length srcdir))) |
| 33 | file)) |
| 34 | |
| 35 | (define (file-mtime<? f1 f2) |
| 36 | (< (stat:mtime (stat f1)) |
| 37 | (stat:mtime (stat f2)))) |
| 38 | |
| 39 | (define (scm->go file) |
| 40 | (let* ((relative (relative-file file)) |
| 41 | (without-extension (string-drop-right relative 4))) |
| 42 | (string-append without-extension ".go"))) |
| 43 | |
| 44 | (define (file-needs-compilation? file) |
| 45 | (let ((go (scm->go file))) |
| 46 | (or (not (file-exists? go)) |
| 47 | (file-mtime<? go file)))) |
| 48 | |
| 49 | (define* (parallel-job-count #:optional (flags (getenv "MAKEFLAGS"))) |
| 50 | "Return the number of parallel jobs as determined by FLAGS, the flags passed |
| 51 | to 'make'." |
| 52 | (match flags |
| 53 | (#f (current-processor-count)) |
| 54 | (flags |
| 55 | (let ((initial-flags (string-tokenize flags))) |
| 56 | (let loop ((flags initial-flags)) |
| 57 | (match flags |
| 58 | (() |
| 59 | ;; Note: GNU make prior to version 4.2 would hide "-j" flags from |
| 60 | ;; $MAKEFLAGS. Thus, check for a "--jobserver" flag here and |
| 61 | ;; assume we're using all cores if specified. |
| 62 | (if (any (lambda (flag) |
| 63 | (string-prefix? "--jobserver" flag)) |
| 64 | initial-flags) |
| 65 | (current-processor-count) ;GNU make < 4.2 |
| 66 | 1)) ;sequential make |
| 67 | (("-j" (= string->number count) _ ...) |
| 68 | (if (integer? count) |
| 69 | count |
| 70 | (current-processor-count))) |
| 71 | ((head tail ...) |
| 72 | (if (string-prefix? "-j" head) |
| 73 | (match (string-drop head 2) |
| 74 | ("" |
| 75 | (current-processor-count)) |
| 76 | ((= string->number count) |
| 77 | (if (integer? count) |
| 78 | count |
| 79 | (current-processor-count)))) |
| 80 | (loop tail))))))))) |
| 81 | |
| 82 | (define (% completed total) |
| 83 | "Return the completion percentage of COMPLETED over TOTAL as an integer." |
| 84 | (inexact->exact (round (* 100. (/ completed total))))) |
| 85 | |
| 86 | ;; Install a SIGINT handler to give unwind handlers in 'compile-file' an |
| 87 | ;; opportunity to run upon SIGINT and to remove temporary output files. |
| 88 | (sigaction SIGINT |
| 89 | (lambda args |
| 90 | (exit 1))) |
| 91 | |
| 92 | (match (command-line) |
| 93 | ((_ . files) |
| 94 | (catch #t |
| 95 | (lambda () |
| 96 | (compile-files srcdir (getcwd) |
| 97 | (filter file-needs-compilation? files) |
| 98 | #:workers (parallel-job-count) |
| 99 | #:host host |
| 100 | #:report-load (lambda (file total completed) |
| 101 | (when file |
| 102 | (format #t "[~3d%] LOAD ~a~%" |
| 103 | (% (+ 1 completed) (* 2 total)) |
| 104 | file) |
| 105 | (force-output))) |
| 106 | #:report-compilation (lambda (file total completed) |
| 107 | (when file |
| 108 | (format #t "[~3d%] GUILEC ~a~%" |
| 109 | (% (+ total completed 1) |
| 110 | (* 2 total)) |
| 111 | (scm->go file)) |
| 112 | (force-output))))) |
| 113 | (lambda _ |
| 114 | (primitive-exit 1)) |
| 115 | (lambda args |
| 116 | ;; Try to report the error in an intelligible way. |
| 117 | (let* ((stack (make-stack #t)) |
| 118 | (frame (if (> (stack-length stack) 1) |
| 119 | (stack-ref stack 1) ;skip the 'throw' frame |
| 120 | (stack-ref stack 0))) |
| 121 | (ui (false-if-exception |
| 122 | (resolve-module '(guix ui)))) |
| 123 | (report (and ui |
| 124 | (false-if-exception |
| 125 | (module-ref ui 'report-load-error))))) |
| 126 | (if report |
| 127 | ;; In Guile <= 2.2.5, 'current-load-port' was not exported. |
| 128 | (let ((load-port ((module-ref (resolve-module '(ice-9 ports)) |
| 129 | 'current-load-port)))) |
| 130 | (report (or (and=> load-port port-filename) "?.scm") |
| 131 | args frame)) |
| 132 | (begin |
| 133 | (print-exception (current-error-port) frame |
| 134 | (car args) (cdr args)) |
| 135 | (display-backtrace stack (current-error-port))))))))) |