build: Use released M0 intead of M1.
[mes.git] / guile / guix / make.scm
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2017 Jan 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 (build
43             check
44             clean
45             group
46             target-prefix?
47             check-target?
48
49             cpp.mescc
50             compile.mescc
51             ld
52
53             bin.mescc
54             bin.gcc
55             snarf
56
57             libc-mes.E
58             mini-libc-mes.E
59             add-target
60             get-target
61
62             system**
63             target-file-name
64
65             target
66             %targets
67             %status))
68
69 (define %status 0)
70 (define %targets '())
71 (define %store-dir ".store")
72 (mkdir-p %store-dir)
73 (define %command-log (open-output-file "script"))
74
75 (define (base-name file-name suffix)
76   (string-drop-right file-name (string-length suffix)))
77
78 (define (system** . command)
79   (format %command-log "~a\n" (string-join command " "))
80   (apply system* command))
81
82 (define (gulp-pipe* . command)
83   (let* ((port (apply open-pipe* (cons OPEN_READ command)))
84          (foo (set-port-encoding! port "ISO-8859-1"))
85          (output (read-string port))
86          (status (close-pipe port)))
87     (format %command-log "~a\n" (string-join command " "))
88     (values output status)))
89
90 (define (assert-gulp-pipe* . command)
91   (receive (output status)
92       (apply gulp-pipe* command)
93     (if (zero? status) (string-trim-right output #\newline)
94         (error (format #f "pipe failed: ~d ~s"
95                        (or (status:exit-val status)
96                            (status:term-sig status)) command)))))
97
98 (define-record-type* <method>
99   method make-method
100   method?
101   (name       method-name)
102   (build      method-build (default (lambda _ #t)))
103   (inputs     method-inputs (default (list))))
104
105 (define-record-type* <target>
106   target make-target
107   target?
108   (file-name  target-file-name (default #f))       ; string
109   (file-names target-file-names (default '()))     ; (string)
110   (hash       target-hash (default #f))            ; string
111   (method     target-method (default method-file)) ; <method>
112   (inputs     target-inputs (default (list)))      ; list
113
114                                                    ; For check targets
115   (baseline   target-baseline (default #f))        ; string: file-name
116   (exit       target-exit (default #f))            ; number
117   (signal     target-signal (default #f)))         ; number
118
119 (define method-file (method (name "FILE")))
120 (define method-check
121   (method (name "CHECK")
122           (build (lambda (o t)
123                    (let* ((inputs (target-inputs t))
124                           (file-name (target-file-name (build (car inputs))))
125                           (run file-name)
126                           (baseline (target-baseline t))
127                           (exit (target-exit t))
128                           (signal (target-signal t))
129                           (log (string-append file-name "-check.log")))
130                      (format (current-error-port) "  CHECK\t~a" (basename file-name))
131                      (receive (output result)
132                          ;; FIXME: quiet MES tests are not fun
133                          (if (string-prefix? "tests/" run) (values #f (system** run "arg1" "arg2" "arg3" "arg4" "arg5"))
134                              (gulp-pipe* run "arg1" "arg2" "arg3" "arg4" "arg5"))
135                        (if (file-exists? log) (delete-file log))
136                        (if (or baseline (and output (not (string-null? output)))) (with-output-to-file log (lambda _ (display output))))
137                        (if baseline (set! result (system* "diff" "-bu" baseline log)))
138                        (let ((status (if (string? result) 0
139                                          (or (status:term-sig result) (status:exit-val result)))))
140                          (store #:add-file log)
141                          (format (current-error-port) "\t[~a]\n"
142                                  (if (or (and signal (= status signal))
143                                          (and exit (= status exit))) "OK"
144                                          (begin (set! %status 1) "FAIL"))))))))))
145
146 (define (hash-target o)
147   (let ((inputs (target-inputs o)))
148     (if (null? inputs) (or (target-hash o) (target-hash (store #:add o)))
149         (let ((input-shas (map hash-target inputs)))
150           (and (every identity input-shas)
151                (let ((method (target-method o)))
152                  (string-hash (format #f "~s" (cons* (target-file-name o)
153                                                      (method-build method)
154                                                      (map target-hash (method-inputs method))
155                                                      input-shas)))))))))
156
157 (define (string-hash o)
158   (number->string (hash o (expt 2 63))))
159
160 (define (file-hash o)
161   (string-hash (with-input-from-file o read-string)))
162
163 (define (store-file-name o)
164   (string-append %store-dir "/" (if (string? o) o
165                                     (target-hash o))))
166
167 (define (assert-link existing-file new-file)
168   (if (not (file-exists? new-file)) (link existing-file new-file)))
169
170 (define store
171   (let ((*store* '()))
172     (define (prune? o)
173       (let ((t (cdr o)))
174         (pair? (target-inputs t))))
175     (define ((file-name? file-name) o)
176       (let ((t (cdr o)))
177         (equal? (target-file-name t) (target-file-name file-name))))
178     (lambda* (#:key add add-file delete get key print prune)
179       (cond ((and add key) (let ((value (target (inherit add) (hash key))))
180                              (set! *store* (assoc-set! (filter (negate (file-name? add)) *store*) key value))
181                              (let ((file-name (target-file-name value)))
182                                (if (and file-name (file-exists? file-name))
183                                    (assert-link file-name (store-file-name value))))
184                              value))
185             (add (let ((key (if (null? (target-inputs add)) (file-hash (target-file-name add))
186                                 (hash-target add))))
187                    (if (not key) (error "store: no hash for:" add))
188                    (store #:add add #:key key)))
189             (add-file (and (file-exists? add-file)
190                            (store #:add (target (file-name add-file)))))
191             ((and get key)
192              (or (assoc-ref *store* key)
193                  (let ((store-file (store-file-name key))
194                        (file-name (target-file-name get)))
195                    (and (file-exists? store-file)
196                         (if (file-exists? file-name) (delete-file file-name))
197                         (link store-file file-name)
198                         (store #:add get #:key key)))))
199             (get (assoc-ref *store* get))
200             (delete (and (assoc-ref *store* delete)
201                          (set! *store* (filter (lambda (e) (not (equal? (car e) delete))) *store*))))
202             (print (pretty-print (map (lambda (e) (cons (target-file-name (cdr e)) (car e))) *store*)))
203             ((eq? prune 'file-system)
204              (set! *store* (filter prune? *store*)))
205             (else (error "store: dunno"))))))
206
207 (define (build o)
208   (let ((hash (hash-target o)))
209     (or (and hash (store #:get o #:key hash))
210         (begin
211           ;;(format (current-error-port) "must rebuild hash=~s\n" hash)
212           (for-each build (target-inputs o))
213           (let ((method (target-method o)))
214             ((method-build method) method o))
215           (store #:add o #:key hash)))))
216
217 (define* (check name #:key baseline (exit 0) (signal #f) (dependencies '()))
218   (target (file-name (string-append "check-" name))
219           (method method-check)
220           (inputs (cons (get-target name) dependencies))
221           (baseline baseline)
222           (exit exit)
223           (signal signal)))
224
225 (define* (group name #:key (dependencies '()))
226   (target (file-name name)
227           (inputs (map get-target dependencies))))
228
229 (define (target->input-files o)
230   (let ((inputs (target-inputs o)))
231     (if (null? inputs) '()
232         (append (cons (target-file-name o) (target-file-names o)) (append-map target->input-files inputs)))))
233
234 (define* (clean #:optional targets)
235   (for-each
236    delete-file
237    (filter file-exists? (delete-duplicates (append-map (cut target->input-files <>) (or targets %targets))))))
238
239 (define (tree o)
240   (let ((inputs (target-inputs o)))
241     (if (null? inputs) o
242         (cons o (append (map tree inputs) (map tree (method-inputs (target-method o))))))))
243
244
245 (define (verbose fmt . o)
246   ;;(apply format (cons* (current-error-port) fmt o))
247   #t
248   )
249
250 (define (PATH-search-path name)
251   (or (search-path (string-split (getenv "PATH") #\:) name)
252       (and (format (current-error-port) "warning: not found: ~a\n" name)
253            name)))
254
255 (define %CC (PATH-search-path "gcc"))
256 (define %CC32 (PATH-search-path "i686-unknown-linux-gnu-gcc"))
257 (define %C-FLAGS
258   '("--std=gnu99"
259     "-O0"
260     "-g"
261     "-D"
262     "POSIX=1"
263     "-I" "src"
264     "-I" "mlibc/include"
265     "--include=mlibc/libc-gcc.c"
266     ))
267 (define %C32-FLAGS
268   '("--std=gnu99"
269     "-O0"
270     "-g"
271     "-I" "src"
272     "-I" "mlibc/include"
273     "--include=mlibc/libc-gcc.c"
274     ))
275
276 (define* (CC.gcc #:key (libc #t) (cc (if libc %CC %CC32)) (c-flags (if libc %C-FLAGS %C32-FLAGS)) (defines '()) (includes '()))
277   (method (name "CC.gcc")
278           (build (lambda (o t)
279                    (let* ((input-files (map target-file-name (target-inputs t)))
280                           (command `(,cc
281                                      "-c"
282                                      ,@(append-map (cut list "-D" <>) defines)
283                                      ,@(append-map (cut list "-I" <>) includes)
284                                      ,@(if libc '() '("-nostdinc" "-fno-builtin"))
285                                      ,@c-flags
286                                      "-o" ,(target-file-name t)
287                                      ,@input-files)))
288                      (format (current-error-port) "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
289                      (unless (zero? (apply system** command))
290                        (format (current-error-port) "FAILED:~s\n" command)
291                        (exit 1)))))
292           (inputs (list (store #:add-file "mlibc/libc-gcc.c"))))) ;; FIXME: FLAGS
293
294 (define* (CPP.mescc #:key (cc %MESCC) (defines '()) (includes '()))
295   (method (name "CPP.mescc")
296           (build (lambda (o t)
297                    (let ((input-files (map target-file-name (target-inputs t))))
298                      (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
299                      (apply system**
300                             `(,cc
301                               "-E"
302                               ,@(append-map (cut list "-D" <>) defines)
303                               ,@(append-map (cut list "-I" <>) includes)
304                               "-o" ,(target-file-name t)
305                               ,@input-files)))))))
306
307 (define %MESCC "guile/mescc.scm")
308 (define* (CC.mescc #:key (cc %MESCC))
309   (method (name "CC.mescc")
310           (build (lambda (o t)
311                    (let ((input-files (map target-file-name (target-inputs t))))
312                      (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
313                      (apply system**
314                             `("guile/mescc.scm" "-c"
315                               "-o" ,(target-file-name t)
316                               ,@input-files)))))
317           (inputs (list (store #:add-file "guile/language/c99/compiler.go")
318                         (store #:add-file "guile/mes/as.go")
319                         (store #:add-file "guile/mes/as-i386.go")
320                         (store #:add-file "guile/mes/M1.go")))))
321
322 (define %M1 (PATH-search-path "M0")) ; M1 is in unreleased mescc-tools 0.2
323 (define %M1-FLAGS
324   '("--LittleEndian"
325     ;;"--Architecture=1"
326     ;;"--BaseAddress=0x1000000"
327     ))
328 (define* (M1.asm #:key (m1 %M1) (m1-flags %M1-FLAGS))
329   (method (name "M1")
330           (build (lambda (o t)
331                    (let* ((input-files (map target-file-name (target-inputs t)))
332                           (input-files (filter (lambda (f) (string-suffix? "M1" f))
333                                                input-files)))
334                      (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
335                      (with-output-to-file (target-file-name t)
336                        (lambda _
337                          (display
338                           (apply assert-gulp-pipe*
339                                  `(,m1
340                                    "-f"
341                                    "stage0/x86.M1"
342                                    ,@(append-map (cut list "-f" <>) input-files)
343                                    ,@m1-flags)))
344                          (newline))))))
345           (inputs (list (store #:add-file "stage0/x86.M1")))))
346
347 (define %HEX2-FLAGS
348   '("--LittleEndian"
349     "--Architecture=1"
350     "--BaseAddress=0x1000000"))
351 (define %HEX2 (PATH-search-path "hex2"))
352
353 (define* (LINK.hex2 #:key (hex2 %HEX2) (hex2-flags %HEX2-FLAGS) debug?)
354   (method (name "LINK.hex2")
355           (build (lambda (o t)
356                    (let* ((input-files (map target-file-name (target-inputs t)))
357                           ;; FIXME: snarf inputs
358                           (input-files (filter (lambda (f) (string-suffix? "hex2" f))
359                                                input-files)))
360                      (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
361                      (with-output-to-file (target-file-name t)
362                        (lambda _
363                          (set-port-encoding! (current-output-port) "ISO-8859-1")
364                          (display
365                           (apply assert-gulp-pipe*
366                                  `(,hex2
367                                    ,@hex2-flags
368                                    "-f"
369                                    ,(if (not debug?) "stage0/elf32-0header.hex2"
370                                         "stage0/elf32-header.hex2")
371                                    ,@(append-map (cut list "-f" <>) input-files)
372                                    "-f"
373                                    ,(if (not debug?) "stage0/elf-0footer.hex2"
374                                         "stage0/elf32-footer-single-main.hex2"))))))
375                      (chmod (target-file-name t) #o755))))
376           (inputs (list (store #:add-file "stage0/elf32-0header.hex2")
377                         (store #:add-file "stage0/elf-0footer.hex2")))))
378
379 (define* (LINK.gcc #:key (cc %CC) (c-flags %C-FLAGS) (libc #t))
380   (method (name "LINK.gcc")
381           (build (lambda (o t)
382                    (let* ((input-files (map target-file-name (target-inputs t)))
383                           (command `(,cc
384                                      ,@c-flags
385                                      ,@(if libc '() '("-nostdlib"))
386                                      "-o"
387                                      ,(target-file-name t)
388                                      ,@input-files)))
389                      (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
390                      (unless (zero? (apply system** command))
391                        (format (current-error-port) "FAILED:~s\n" command)
392                        (exit 1)))))))
393
394 (define SNARF "build-aux/mes-snarf.scm")
395 (define (SNARF.mes mes?)
396   (method (name "SNARF.mes")
397           (build (lambda (o t)
398                    (let* ((input-files (map target-file-name (target-inputs t)))
399                           (command `(,SNARF
400                                      ,@(if mes? '("--mes") '())
401                                      ,@input-files)))
402                      (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
403                      (unless (zero? (apply system** command))
404                        (format (current-error-port) "FAILED:~s\n" command)
405                        (exit 1)))))))
406
407 (define* (cpp.mescc input-file-name #:key (cc %MESCC) (defines '()) (includes '()))
408   (let* ((c-target (target (file-name input-file-name)))
409          (base-name (base-name input-file-name ".c"))
410          (suffix ".E")
411          (target-file-name (string-append base-name suffix)))
412     (target (file-name target-file-name)
413             (inputs (list c-target))
414             (method (CPP.mescc #:cc cc #:defines defines #:includes includes)))))
415
416 (define mini-libc-mes.E (cpp.mescc "mlibc/mini-libc-mes.c"))
417 (define libc-mes.E (cpp.mescc "mlibc/libc-mes.c"))
418
419 (define* (compile.gcc input-file-name #:key (libc #t) (cc (if libc %CC %CC32)) (defines '()) (includes '()))
420   (let* ((base-name (base-name input-file-name ".c"))
421          (cross (if libc "" "mlibc-"))
422          (suffix (string-append "." cross "o"))
423          (target-file-name (string-append base-name suffix))
424          (c-target (target (file-name input-file-name))))
425     (target (file-name target-file-name)
426             (inputs (list c-target))
427             (method (CC.gcc #:cc cc #:libc libc #:defines defines #:includes includes)))))
428
429 (define* (compile.mescc input-file-name #:key (cc %CC) (libc libc-mes.E) (defines '()) (includes '()))
430   (let* ((base-name (base-name input-file-name ".c"))
431          ;;(foo (format (current-error-port) "COMPILE[~s .c] base=~s\n" input-file-name base-name))
432          (suffix (cond ((not libc) ".0-M1")
433                        ((eq? libc libc-mes.E) ".M1")
434                        (else ".mini-M1")))
435          (target-file-name (string-append base-name suffix))
436          (E-target (cpp.mescc input-file-name #:cc cc #:defines defines #:includes includes)))
437     (target (file-name target-file-name)
438             (inputs `(,@(if libc (list libc) '()) ,E-target))
439             (method (CC.mescc #:cc cc)))))
440
441 (define* (m1-asm input-file-name #:key (cc %MESCC) (m1 %M1) (libc libc-mes.E) (defines '()) (includes '()))
442   (let* ((base-name (base-name input-file-name ".c"))
443          ;;(foo (format (current-error-port) "m1-asm[~s .m1] base=~s\n" input-file-name base-name))
444          (suffix (cond ((not libc) ".0-hex2")
445                        ((eq? libc libc-mes.E) ".hex2")
446                        (else ".mini-hex2")))
447          (target-file-name (string-append base-name suffix))
448          (m1-target (compile.mescc input-file-name #:cc cc #:libc libc #:defines defines #:includes includes))
449          (libc.m1 (cond ((eq? libc libc-mes.E)
450                          (compile.mescc "mlibc/libc-mes.c" #:libc #f #:defines defines #:includes includes))
451                         ((eq? libc mini-libc-mes.E)
452                          (compile.mescc "mlibc/mini-libc-mes.c" #:libc #f #:defines defines #:includes includes))
453                         (else #f))))
454     (target (file-name target-file-name)
455             ;;(inputs `(,@(if libc (list libc.m1) '()) ,m1-target))
456             (inputs `(,m1-target))
457             (method (M1.asm #:m1 m1)))))
458
459 (define* (bin.mescc input-file-name #:key (cc %MESCC) (hex2 %HEX2) (m1 %M1) (libc libc-mes.E) (dependencies '()) (defines '()) (includes '()))
460   (let* ((base-name (base-name input-file-name ".c"))
461          ;;(foo (format (current-error-port) "bin[~s .c] base=~s\n" input-file-name base-name))
462          (suffix (cond ((not libc) ".0-guile")
463                        ((eq? libc libc-mes.E) ".guile")
464                        (else ".mini-guile")))
465          (target-file-name (string-append base-name suffix))
466          (hex2-target (m1-asm input-file-name #:m1 m1 #:cc cc #:libc libc #:defines defines #:includes includes)))
467     (target (file-name target-file-name)
468             (inputs (cons hex2-target dependencies))
469             (method (LINK.hex2 #:hex2 hex2 #:debug? (eq? libc libc-mes.E))))))
470
471 (define* (bin.gcc input-file-name #:key (libc #t) (cc (if libc %CC %CC32)) (dependencies '()) (defines '()) (includes '()))
472   (let* ((base-name (base-name input-file-name ".c"))
473          (suffix (if libc ".gcc" ".mlibc-gcc"))
474          (target-file-name (string-append base-name suffix))
475          (o-target (compile.gcc input-file-name #:cc cc #:libc libc #:defines defines #:includes includes)))
476     (target (file-name target-file-name)
477             (inputs (list o-target))
478             (method (LINK.gcc #:cc cc #:libc libc)))))
479
480 (define* (snarf input-file-name #:key (dependencies '()) (mes? #t))
481   (let* ((base-name (base-name input-file-name ".c"))
482          (suffixes '(".h" ".i" ".environment.i" ".symbol-names.i" ".symbols.i"  ".symbols.h"))
483          (suffixes (if mes? (map (cut string-append ".mes" <>) suffixes) suffixes))
484          (target-file-names (map (cut string-append base-name <>) suffixes))
485          (snarf-target (target (file-name input-file-name))))
486     (target (file-name (car target-file-names))
487             (file-names (cdr target-file-names))
488             (inputs (cons snarf-target dependencies))
489             ;;(inputs (list snarf-target))
490             (method (SNARF.mes mes?)))))
491
492 (define ((target-prefix? prefix) o)
493   (string-prefix? prefix (target-file-name o)))
494
495 (define (check-target? o)
496   ((target-prefix? "check-") o))
497
498 (define (add-target o)
499   (set! %targets (append %targets (list o)))
500   o)
501 (define (get-target o)
502   (if (target? o) o
503       (find (lambda (t) (equal? (target-file-name t) o)) %targets)))