build: Install naive diff.
[mes.git] / build-aux / compile-all.scm
1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2016 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
3 ;;; Copyright © 2016, 2017 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 (system base target)
21              (system base message)
22              (ice-9 match)
23              (ice-9 threads))
24
25 (define (mkdir-p dir)
26   "Create directory DIR and all its ancestors."
27   (define absolute?
28     (string-prefix? "/" dir))
29
30   (define not-slash
31     (char-set-complement (char-set #\/)))
32
33   (let loop ((components (string-tokenize dir not-slash))
34              (root       (if absolute?
35                              ""
36                              ".")))
37     (match components
38       ((head tail ...)
39        (let ((path (string-append root "/" head)))
40          (catch 'system-error
41            (lambda ()
42              (mkdir path)
43              (loop tail path))
44            (lambda args
45              (if (= EEXIST (system-error-errno args))
46                  (loop tail path)
47                  (apply throw args))))))
48       (() #t))))
49
50 (define warnings
51   '(unsupported-warning format unbound-variable arity-mismatch))
52
53 (define host (getenv "host"))
54
55 (define srcdir (getenv "srcdir"))
56
57 (define (relative-file file)
58   (if (string-prefix? (string-append srcdir "/") file)
59       (string-drop file (+ 1 (string-length srcdir)))
60       file))
61
62 (define (file-mtime<? f1 f2)
63   (< (stat:mtime (stat f1))
64      (stat:mtime (stat f2))))
65
66 (define (scm->go file)
67   (let* ((relative (relative-file file))
68          (without-extension (string-drop-right relative 4)))
69     (string-append without-extension ".go")))
70
71 (define (scm->mes file)
72   (let ((base (string-drop-right file 4)))
73     (string-append base ".mes")))
74
75 (define (file-needs-compilation? file)
76   (let ((go (scm->go file)))
77     (or (not (file-exists? go))
78         (file-mtime<? go file)
79         (let ((mes (scm->mes file))) ; FIXME: try to respect (include-from-path ".mes")
80           (and (file-exists? mes)
81                (file-mtime<? go mes))))))
82
83 (define (file->module file)
84   (let* ((relative (relative-file file))
85          (module-path (string-drop-right relative 4)))
86     (map string->symbol
87          (string-split module-path #\/))))
88
89 ;;; To work around <http://bugs.gnu.org/15602> (FIXME), we want to load all
90 ;;; files to be compiled first.  We do this via resolve-interface so that the
91 ;;; top-level of each file (module) is only executed once.
92 (define (load-module-file file)
93   (let ((module (file->module file)))
94     (format #t "  LOAD     ~a~%" module)
95     (resolve-interface module)))
96
97 (cond-expand
98  (guile-2.2 (use-modules (language tree-il optimize)
99                          (language cps optimize)))
100  (else #f))
101
102 (define %default-optimizations
103   ;; Default optimization options (equivalent to -O2 on Guile 2.2).
104   (cond-expand
105    (guile-2.2 (append (tree-il-default-optimization-options)
106                       (cps-default-optimization-options)))
107     (else '())))
108
109 (define %lightweight-optimizations
110   ;; Lightweight optimizations (like -O0, but with partial evaluation).
111   (let loop ((opts %default-optimizations)
112              (result '()))
113     (match opts
114       (() (reverse result))
115       ((#:partial-eval? _ rest ...)
116        (loop rest `(#t #:partial-eval? ,@result)))
117       ((kw _ rest ...)
118        (loop rest `(#f ,kw ,@result))))))
119
120 (define (optimization-options file)
121   (if (string-contains file "gnu/packages/")
122       %lightweight-optimizations                  ;build faster
123       '()))
124
125 (define (compile-file* file output-mutex)
126   (let ((go (scm->go file)))
127     (with-mutex output-mutex
128       (format #t "  GUILEC   ~a~%" go)
129       (force-output))
130     (mkdir-p (dirname go))
131     (with-fluids ((*current-warning-prefix* ""))
132       (with-target host
133         (lambda ()
134           (compile-file file
135                         #:output-file go
136                         #:opts `(#:warnings ,warnings
137                                  ,@(optimization-options file))))))))
138
139 ;; Install a SIGINT handler to give unwind handlers in 'compile-file' an
140 ;; opportunity to run upon SIGINT and to remove temporary output files.
141 (sigaction SIGINT
142   (lambda args
143     (exit 1)))
144
145 (match (command-line)
146   ((_ . files)
147    (let ((files (filter file-needs-compilation? files)))
148      (for-each load-module-file files)
149      (let ((mutex (make-mutex)))
150        ;; Make sure compilation related modules are loaded before starting to
151        ;; compile files in parallel.
152        (compile #f)
153        (par-for-each (lambda (file)
154                        (compile-file* file mutex))
155                      files)))))
156
157 ;;; Local Variables:
158 ;;; eval: (put 'with-target 'scheme-indent-function 1)
159 ;;; End: