core: Use length__.
[mes.git] / guile / guix / make.scm
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; This file is part of Mes.
7 ;;;
8 ;;; Mes is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
12 ;;;
13 ;;; Mes is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;;; GNU General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;;; Commentary:
22
23 ;;; make
24
25 ;;; Code:
26
27 (define-module (guix make)
28   #:use-module (ice-9 curried-definitions)
29   #:use-module (ice-9 format)
30   #:use-module (ice-9 optargs)
31   #:use-module (ice-9 popen)
32   #:use-module (ice-9 pretty-print)
33   #:use-module (ice-9 rdelim)
34   #:use-module (ice-9 receive)
35
36   #:use-module (srfi srfi-1)
37   #:use-module (srfi srfi-26)
38
39   #:use-module (guix records)
40   #:use-module (guix shell-utils)
41
42   #:export (base-name
43             build
44             check
45             clean
46             group
47             install
48             target-prefix?
49             check-target?
50             install-target?
51
52             cpp.mescc
53             compile.mescc
54             compile.gcc
55             ld
56
57             bin.mescc
58             bin.gcc
59             snarf
60             m1.as
61
62             crt1.mlibc-o
63             libc-gcc.mlibc-o
64             libc+tcc-gcc.mlibc-o
65
66             add-target
67             get-target
68
69             conjoin
70             system**
71             target-file-name
72
73             method
74             target
75             store
76             target-inputs
77             method-name
78             assert-gulp-pipe*
79
80             PATH-search-path
81
82             %MESCC
83             %HEX2
84             %M1
85
86             %targets
87             %status
88
89             %version
90             %prefix
91             %datadir
92             %docdir
93             %moduledir
94             %guiledir
95             %godir))
96
97 (define %status 0)
98 (define %targets '())
99 (define %store-dir ".store")
100 (mkdir-p %store-dir)
101 (define %command-log (open-output-file "script"))
102
103 (define (base-name file-name suffix)
104   (string-drop-right file-name (string-length suffix)))
105
106 (define (conjoin . predicates)
107   (lambda (. arguments)
108     (every (cut apply <> arguments) predicates)))
109
110 (define (system** . command)
111   (format %command-log "~a\n" (string-join command " "))
112   (unless (zero? (apply system* command))
113     (format (current-error-port) "FAILED:~s\n" command)
114     (exit 1)))
115
116 (define (gulp-pipe* . command)
117   (let* ((port (apply open-pipe* (cons OPEN_READ command)))
118          (foo (set-port-encoding! port "ISO-8859-1"))
119          (output (read-string port))
120          (status (close-pipe port)))
121     (format %command-log "~a\n" (string-join command " "))
122     (values output status)))
123
124 (define (assert-gulp-pipe* . command)
125   (receive (output status)
126       (apply gulp-pipe* command)
127     (if (zero? status) (string-trim-right output #\newline)
128         (error (format #f "pipe failed: ~d ~s"
129                        (or (status:exit-val status)
130                            (status:term-sig status)) command)))))
131
132 (define-record-type* <method>
133   method make-method
134   method?
135   (name       method-name)
136   (build      method-build (default (lambda _ #t)))
137   (inputs     method-inputs (default (list))))
138
139 (define-record-type* <target>
140   target make-target
141   target?
142   (file-name  target-file-name (default #f))       ; string
143   (file-names target-file-names (default '()))     ; (string)
144   (hash       target-hash (default #f))            ; string
145   (method     target-method (default method-file)) ; <method>
146   (inputs     target-inputs (default (list)))      ; list
147
148                                                    ; For check targets
149   (baseline   target-baseline (default #f))        ; string: file-name
150   (exit       target-exit (default #f))            ; number
151   (signal     target-signal (default #f)))         ; number
152
153 (define method-file (method (name "FILE")))
154 (define method-check
155   (method (name "CHECK")
156           (build (lambda (o t)
157                    (let* ((inputs (target-inputs t))
158                           (file-name (target-file-name (build (car inputs))))
159                           (run file-name)
160                           (baseline (target-baseline t))
161                           (exit (target-exit t))
162                           (signal (target-signal t))
163                           (log (string-append file-name "-check.log")))
164                      (format (current-error-port) "  CHECK\t~a" (basename file-name))
165                      (receive (output result)
166                          ;; FIXME: quiet MES tests are not fun
167                          (if (string-prefix? "tests/" run) (values #f (system* run "arg1" "arg2" "arg3" "arg4" "arg5"))
168                              (gulp-pipe* run "arg1" "arg2" "arg3" "arg4" "arg5"))
169                        (if (file-exists? log) (delete-file log))
170                        (if (or baseline (and output (not (string-null? output)))) (with-output-to-file log (lambda _ (display output))))
171                        (if baseline (set! result (system* "diff" "-bu" baseline log)))
172                        (let ((status (if (string? result) 0
173                                          (or (status:term-sig result) (status:exit-val result)))))
174                          (if (file-exists? log) (store #:add-file log))
175                          (format (current-error-port) "\t[~a]\n"
176                                  (if (or (and signal (= status signal))
177                                          (and exit (= status exit))) "OK"
178                                          (begin (set! %status 1) "FAIL"))))))))))
179
180 (define %version (or (getenv "VERSION") "git"))
181 (define %prefix (or (getenv "PREFIX") ""))
182 (define %datadir "share/mes")
183 (define %docdir "share/doc/mes")
184 (define %moduledir (string-append %datadir "/module"))
185 (define %guiledir (string-append "share/guile/site/" (effective-version)))
186 (define %godir (string-append "lib/guile/" (effective-version) "/site-ccache"))
187
188 (define* (method-cp #:key substitutes)
189   (method (name "INSTALL")
190           (build (lambda (o t)
191                    (let ((file-name (target-file-name t)))
192                      (mkdir-p (dirname file-name))
193                      (format (current-error-port) "  INSTALL\t~a\n" file-name)
194                      (copy-file ((compose target-file-name car target-inputs) t) file-name)
195                      (if substitutes
196                          (begin
197                            (substitute* file-name
198                              (("module/") (string-append %prefix "/" %moduledir "/"))
199                              (("@DATADIR@") (string-append %prefix "/" %datadir "/"))
200                              (("@DOCDIR@") (string-append %prefix "/" %docdir "/"))
201                              (("@GODIR@") (string-append %prefix "/" %godir "/"))
202                              (("@GUILEDIR@") (string-append %prefix "/" %guiledir "/"))
203                              (("@MODULEDIR@") (string-append %prefix "/" %moduledir "/"))
204                              (("@PREFIX@") (string-append %prefix "/"))
205                              (("@VERSION@") %version)))))))))
206
207 (define (hash-target o)
208   (if (find (negate identity) (target-inputs o))
209       (format (current-error-port) "invalid inputs[~s]: ~s\n" (target-file-name o) (target-inputs o)))
210   (let ((inputs (target-inputs o)))
211     (if (null? inputs) (or (target-hash o) (target-hash (store #:add o)))
212         (let ((input-shas (map hash-target inputs)))
213           (and (every identity input-shas)
214                (let ((method (target-method o)))
215                  (string-hash (format #f "~s" (cons* (target-file-name o)
216                                                      (method-build method)
217                                                      (map target-hash (method-inputs method))
218                                                      input-shas)))))))))
219
220 (define (string-hash o)
221   (number->string (hash o (expt 2 31))))
222
223 (define (file-hash o)
224   (string-hash (with-input-from-file o read-string)))
225
226 (define (store-file-name o)
227   (string-append %store-dir "/" (if (string? o) o
228                                     (target-hash o))))
229
230 (define (link-or-cp existing-file new-file)
231   (catch #t
232     (lambda _ (link existing-file new-file))
233     (lambda _ (copy-file existing-file new-file))))
234
235 (define (assert-link existing-file new-file)
236   (if (not (file-exists? new-file)) (link-or-cp existing-file new-file)))
237
238 (define store
239   (let ((*store* '()))
240     (define (prune? o)
241       (let ((t (cdr o)))
242         (pair? (target-inputs t))))
243     (define ((file-name? file-name) o)
244       (let ((t (cdr o)))
245         (equal? (target-file-name t) (target-file-name file-name))))
246     (lambda* (#:key add add-file delete get key print prune)
247       (cond ((and add key) (let ((value (target (inherit add) (hash key))))
248                              (set! *store* (assoc-set! (filter (negate (file-name? add)) *store*) key value))
249                              (let ((file-name (target-file-name value)))
250                                (if (and file-name (file-exists? file-name))
251                                    (assert-link file-name (store-file-name value))))
252                              value))
253             (add (let ((key (if (null? (target-inputs add)) (file-hash (target-file-name add))
254                                 (hash-target add))))
255                    (if (not key) (error "store: no hash for:" add))
256                    (store #:add add #:key key)))
257             (add-file
258              (or (and=> (find (lambda (t) (equal? (target-file-name t) add-file)) (map cdr *store*))
259                         (compose (cut store #:get <>) target-hash))
260                  (and (file-exists? add-file)
261                       (store #:add (target (file-name add-file))))
262                  (error (format #f "store add-file: no such file: ~s\n" add-file))))
263             ((and get key)
264              (or (assoc-ref *store* key)
265                  (let ((store-file (store-file-name key))
266                        (file-name (target-file-name get)))
267                    (and (file-exists? store-file)
268                         (if (file-exists? file-name) (delete-file file-name))
269                         (link-or-cp store-file file-name)
270                         (store #:add get #:key key)))))
271             (get (assoc-ref *store* get))
272             (delete (and (assoc-ref *store* delete)
273                          (set! *store* (filter (lambda (e) (not (equal? (car e) delete))) *store*))))
274             (print (pretty-print (map (lambda (e) (cons (target-file-name (cdr e)) (car e))) *store*)))
275             ((eq? prune 'file-system)
276              (set! *store* (filter prune? *store*)))
277             (else (error "store: dunno"))))))
278
279 (define (build o)
280   (let ((hash (hash-target o)))
281     (or (and hash (store #:get o #:key hash))
282         (begin
283           ;;(format (current-error-port) "must rebuild hash=~s\n" hash)
284           (for-each build (target-inputs o))
285           (let ((method (target-method o)))
286             ((method-build method) method o))
287           (store #:add o #:key hash)))))
288
289 (define* (check name #:key baseline (exit 0) (signal #f) (dependencies '()))
290   (target (file-name (string-append "check-" name))
291           (method method-check)
292           (inputs (cons (get-target name) dependencies))
293           (baseline baseline)
294           (exit exit)
295           (signal signal)))
296
297 (define* (install name #:key (dir (dirname name)) (installed-name (basename name)) (prefix %prefix) substitutes (dependencies '()))
298   (target (file-name (string-append prefix "/" dir "/" installed-name))
299           (method (method-cp #:substitutes substitutes))
300           (inputs (cons (or (get-target name)
301                             (store #:add-file name)) dependencies))))
302
303 (define* (group name #:key (dependencies '()))
304   (target (file-name name)
305           (inputs (map get-target dependencies))))
306
307 (define (target->input-files o)
308   (let ((inputs (target-inputs o)))
309     (if (null? inputs) '()
310         (append (cons (target-file-name o) (target-file-names o)) (append-map target->input-files inputs)))))
311
312 (define* (clean #:optional targets)
313   (for-each
314    delete-file
315    (filter file-exists? (delete-duplicates (append-map (cut target->input-files <>) (or targets %targets))))))
316
317 (define (tree o)
318   (let ((inputs (target-inputs o)))
319     (if (null? inputs) o
320         (cons o (append (map tree inputs) (map tree (method-inputs (target-method o))))))))
321
322
323 (define (verbose fmt . o)
324   ;;(apply format (cons* (current-error-port) fmt o))
325   #t
326   )
327
328 (define* (PATH-search-path name #:key (default name))
329   (or (search-path (string-split (getenv "PATH") #\:) name)
330       (and (format (current-error-port) "warning: not found: ~a\n" name)
331            default)))
332
333 (define %CC (or (getenv "CC") (PATH-search-path "gcc")))
334 (define %CC32 (or (getenv "CC32")
335                   (PATH-search-path "i686-unknown-linux-gnu-gcc" #:default #f)
336                   (and (format (current-error-port) "warning: CC32 not found, trying gcc -m32")
337                        %CC)))
338
339 (define %C-FLAGS
340   '("--std=gnu99"
341     "-O0"
342     "-g"
343     "-D"
344     "POSIX=1"
345     "-I" "src"
346     "-I" "lib"
347     "-I" "include"
348     "--include=lib/libc-gcc.c"))
349
350 (define %C32-FLAGS
351   '("--std=gnu99"
352     "-O0"
353     "-fno-stack-protector"
354     "-g"
355     "-m32"
356     "-I" "src"
357     "-I" "lib"
358     "-I" "include"))
359
360 (define* (CC.gcc #:key (libc #t) (cc (if (eq? libc #t) %CC %CC32)) (c-flags (if (eq? libc #t) %C-FLAGS %C32-FLAGS)) (defines '()) (includes '()))
361   (method (name "CC.gcc")
362           (build (lambda (o t)
363                    (let* ((input-files (map target-file-name (target-inputs t)))
364                           (command `(,cc
365                                      "-c"
366                                      ,@(append-map (cut list "-D" <>) defines)
367                                      ,@(append-map (cut list "-I" <>) includes)
368                                      ,@(if (eq? libc #t) '() '("-nostdinc" "-fno-builtin"))
369                                      ,@c-flags
370                                      "-o" ,(target-file-name t)
371                                      ,@(filter (cut string-suffix? ".c" <>) input-files))))
372                      (format (current-error-port) "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
373                      (apply system** command))))))
374
375 (define* (CPP.mescc #:key (cc %MESCC) (defines '()) (includes '()))
376   (method (name "CPP.mescc")
377           (build (lambda (o t)
378                    (let ((input-files (map target-file-name (target-inputs t))))
379                      (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
380                      (apply system**
381                             `(,cc
382                               "-E"
383                               ,@(append-map (cut list "-D" <>) defines)
384                               ,@(append-map (cut list "-I" <>) includes)
385                               "-o" ,(target-file-name t)
386                               ,@input-files)))))))
387
388 (define %MESCC "scripts/mescc")
389 (define* (CC.mescc #:key (cc %MESCC))
390   (method (name "CC.mescc")
391           (build (lambda (o t)
392                    (let ((input-files (map target-file-name (target-inputs t))))
393                      (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
394                      (setenv "MES" "guile")
395                      (apply system**
396                             `("scripts/mescc" "-c"
397                               "-o" ,(target-file-name t)
398                               ,@input-files))
399                      (unsetenv "MES"))))
400           (inputs (list (store #:add-file "guile/language/c99/info.go")
401                         (store #:add-file "guile/language/c99/compiler.go")
402                         (store #:add-file "guile/mes/as-i386.go")
403                         (store #:add-file "guile/mes/as.go")
404                         (store #:add-file "guile/mes/elf.go")
405                         (store #:add-file "guile/mes/bytevectors.go")
406                         (store #:add-file "guile/mes/M1.go")
407                         (store #:add-file "guile/mes/guile.go")))))
408
409 (define %M1 (or (PATH-search-path "M1" #:default #f)
410                 (PATH-search-path "M0" #:default #f) ; M1 is in unreleased mescc-tools 0.2
411                 (and (format (current-error-port) "error: no macro assembler found, please install mescc-tools\n")
412                      (exit 1))))
413 (define %M0-FLAGS
414   '("--LittleEndian"))
415 (define %M1-FLAGS
416   '("--LittleEndian"
417     "--Architecture=1"))
418 (if (equal? (basename %M1) "M0")
419     (set! %M1-FLAGS %M0-FLAGS))
420
421 (define* (M1.as #:key (m1 %M1) (m1-flags %M1-FLAGS))
422   (method (name "M1")
423           (build (lambda (o t)
424                    (let* ((input-files (map target-file-name (target-inputs t)))
425                           (input-files (filter (lambda (f) (string-suffix? "M1" f))
426                                                input-files)))
427                      (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
428                      (with-output-to-file (target-file-name t)
429                        (lambda _
430                          (display
431                           (apply assert-gulp-pipe*
432                                  `(,m1
433                                    "-f"
434                                    "stage0/x86.M1"
435                                    ,@(append-map (cut list "-f" <>) input-files)
436                                    ,@m1-flags)))
437                          (newline))))))
438           (inputs (list (store #:add-file "stage0/x86.M1")))))
439
440 (define* (LINK.gcc #:key (cc %CC) (libc #t) (c-flags (if (eq? libc #t) %C-FLAGS %C32-FLAGS)) (crt1 #f))
441   (method (name "LINK.gcc")
442           (build (lambda (o t)
443                    (let* ((input-files (map target-file-name (target-inputs t)))
444                           (command `(,cc
445                                      ,@c-flags
446                                      ,@(if (eq? libc #t) '() '("-nostdlib"))
447                                      "-o"
448                                      ,(target-file-name t)
449                                      ,@(if crt1 (list (target-file-name crt1))'())
450                                      ,@input-files
451                                      ,@(cond ((eq? libc #t) '())
452                                              (libc (list (target-file-name libc)))
453                                              (else '())))))
454                      (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
455                      (apply system** command))))))
456
457 (define SNARF "build-aux/mes-snarf.scm")
458 (define (SNARF.mes mes?)
459   (method (name "SNARF.mes")
460           (build (lambda (o t)
461                    (let* ((input-files (map target-file-name (target-inputs t)))
462                           (command `(,SNARF
463                                      ,@(if mes? '("--mes") '())
464                                      ,@input-files)))
465                      (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
466                      (apply system** command))))))
467
468 (define* (cpp.mescc input-file-name #:key (cc %MESCC) (defines '()) (includes '()) (dependencies '()))
469   (let* ((c-target (target (file-name input-file-name)))
470          (base-name (base-name input-file-name ".c"))
471          (suffix ".E")
472          (target-file-name (string-append base-name suffix)))
473     (target (file-name target-file-name)
474             (inputs (cons c-target dependencies))
475             (method (CPP.mescc #:cc cc #:defines defines #:includes includes)))))
476
477 (define* (compile.gcc input-file-name #:key (libc #t) (cc (if (eq? libc #t) %CC %CC32)) (defines '()) (includes '()) (dependencies '()))
478   (let* ((base-name (base-name input-file-name ".c"))
479          (cross (if (eq? libc #t) "" "mlibc-"))
480          (suffix (string-append "." cross "o"))
481          (target-file-name (string-append base-name suffix))
482          (c-target (target (file-name input-file-name))))
483     (target (file-name target-file-name)
484             (inputs (cons c-target dependencies))
485             (method (CC.gcc #:cc cc #:libc libc #:defines defines #:includes includes)))))
486
487 (define* (compile.mescc input-file-name #:key (cc %MESCC) (defines '()) (includes '()) (dependencies '()))
488   (let* ((base-name (base-name input-file-name ".c"))
489          (suffix ".M1")
490          (target-file-name (string-append base-name suffix))
491          (E-target (cpp.mescc input-file-name #:cc cc #:defines defines #:includes includes #:dependencies dependencies)))
492     (target (file-name target-file-name)
493             (inputs `(,E-target))
494             (method (CC.mescc #:cc cc)))))
495
496 (define* (m1.as input-file-name #:key (cc %MESCC) (m1 %M1) (defines '()) (includes '()) (dependencies '()))
497   (let* ((base-name (base-name input-file-name ".c"))
498          ;;(foo (format (current-error-port) "m1.as[~s .m1] base=~s\n" input-file-name base-name))
499          (suffix ".hex2")
500          (target-file-name (string-append base-name suffix))
501          (m1-target (compile.mescc input-file-name #:cc cc #:defines defines #:includes includes #:dependencies dependencies)))
502     (target (file-name target-file-name)
503             (inputs `(,m1-target))
504             (method (M1.as #:m1 m1)))))
505
506 (define* (bin.gcc input-file-name #:key (libc #t) (crt1 (if (eq? libc #t) #f crt1.mlibc-o)) (cc (if (eq? libc #t) %CC %CC32)) (dependencies '()) (defines '()) (includes '()))
507   (and cc
508        (let* ((base-name (base-name input-file-name ".c"))
509           (suffix (if (eq? libc #t) ".gcc" ".mlibc-gcc"))
510           (target-file-name (string-append base-name suffix))
511           (o-target (compile.gcc input-file-name #:cc cc #:libc libc #:defines defines #:includes includes #:dependencies dependencies)))
512      (target (file-name target-file-name)
513              (inputs (list o-target))
514              (method (LINK.gcc #:cc cc #:libc libc #:crt1 crt1))))))
515
516 (define* (snarf input-file-name #:key (dependencies '()) (mes? #t))
517   (let* ((base-name (base-name input-file-name ".c"))
518          (suffixes '(".h" ".i" ".environment.i" ".symbol-names.i" ".symbols.i"  ".symbols.h"))
519          (suffixes (if mes? (map (cut string-append ".mes" <>) suffixes) suffixes))
520          (target-file-names (map (cut string-append base-name <>) suffixes))
521          (snarf-target (target (file-name input-file-name))))
522     (target (file-name (car target-file-names))
523             (file-names (cdr target-file-names))
524             (inputs (cons snarf-target dependencies))
525             ;;(inputs (list snarf-target))
526             (method (SNARF.mes mes?)))))
527
528 (define ((target-prefix? prefix) o)
529   (string-prefix? prefix (target-file-name o)))
530
531 (define (check-target? o)
532   (and o ((target-prefix? "check-") o)))
533
534 (define (install-target? o)
535   (and o ((target-prefix? (or (getenv "PREFIX") "/")) o)))
536
537 (define (add-target o)
538   (and o (set! %targets (append %targets (list o))))
539   o)
540 (define (get-target o)
541   (if (target? o) o
542       (find (lambda (t) (equal? (target-file-name t) o)) %targets)))
543
544 (define crt1.mlibc-o (compile.gcc "lib/crt1.c" #:libc #f))
545 (define libc-gcc.mlibc-o (compile.gcc "lib/libc-gcc.c" #:libc #f))
546 (define libc+tcc-gcc.mlibc-o (compile.gcc "lib/libc+tcc-gcc.c" #:libc #f))