projects/guix·blob master · refs

150 lines · 6.2 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2016 Taylan Ulrich Bayırlı/Kammer <[email protected]>
3;;; Copyright © 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <[email protected]>
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
51to '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 (parallel-job-count*)
83 ;; XXX: Work around memory requirements not sustainable on i686 above '-j4'
84 ;; or so: <https://bugs.gnu.org/40522>.
85 (let ((count (parallel-job-count)))
86 (if (string-prefix? "i686" %host-type)
87 (min count 4)
88 count)))
89
90(define (% completed total)
91 "Return the completion percentage of COMPLETED over TOTAL as an integer."
92 (inexact->exact (round (* 100. (/ completed total)))))
93
94;; Install a SIGINT handler to give unwind handlers in 'compile-file' an
95;; opportunity to run upon SIGINT and to remove temporary output files.
96(sigaction SIGINT
97 (lambda args
98 (exit 1)))
99
100(match (command-line)
101 ((_ "--total" (= string->number grand-total)
102 "--completed" (= string->number processed)
103 . files)
104 ;; GRAND-TOTAL is the total number of .scm files in the project; PROCESSED
105 ;; is the total number of .scm files already compiled in previous
106 ;; invocations of this script.
107 (catch #t
108 (lambda ()
109 (let* ((to-build (filter file-needs-compilation? files))
110 (processed (+ processed
111 (- (length files) (length to-build)))))
112 (compile-files srcdir (getcwd) to-build
113 #:workers (parallel-job-count*)
114 #:host host
115 #:report-load (lambda (file total completed)
116 (when file
117 (format #t "[~3d%] LOAD ~a~%"
118 (% (+ 1 completed
119 (* 2 processed))
120 (* 2 grand-total))
121 file)
122 (force-output)))
123 #:report-compilation (lambda (file total completed)
124 (when file
125 (format #t "[~3d%] GUILEC ~a~%"
126 (% (+ total completed 1
127 (* 2 processed))
128 (* 2 grand-total))
129 (scm->go file))
130 (force-output))))))
131 (lambda _
132 (primitive-exit 1))
133 (lambda args
134 ;; Try to report the error in an intelligible way.
135 (let* ((stack (make-stack #t))
136 (frame (if (> (stack-length stack) 1)
137 (stack-ref stack 1) ;skip the 'throw' frame
138 (stack-ref stack 0)))
139 (ui (false-if-exception
140 (resolve-module '(guix ui))))
141 (report (and ui
142 (false-if-exception
143 (module-ref ui 'report-load-error)))))
144 (if report
145 (report (or (and=> (current-load-port) port-filename) "?.scm")
146 args frame)
147 (begin
148 (print-exception (current-error-port) frame
149 (car args) (cdr args))
150 (display-backtrace stack (current-error-port)))))))))