3c13f7049db49c73337dea36be0f1c8ce2867f43
[mes.git] / module / mescc / mescc.scm
1 ;;; GNU Mes --- Maxwell Equations of Software
2 ;;; Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
3 ;;;
4 ;;; This file is part of GNU Mes.
5 ;;;
6 ;;; GNU Mes is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or (at
9 ;;; your option) any later version.
10 ;;;
11 ;;; GNU Mes is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 ;;; GNU General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
18
19 (define-module (mescc mescc)
20   #:use-module (srfi srfi-1)
21   #:use-module (srfi srfi-26)
22   #:use-module (ice-9 pretty-print)
23   #:use-module (ice-9 getopt-long)
24   #:use-module (mes misc)
25
26   #:use-module (mescc i386 info)
27   #:use-module (mescc x86_64 info)
28   #:use-module (mescc preprocess)
29   #:use-module (mescc compile)
30   #:use-module (mescc M1)
31   #:export (count-opt
32             mescc:preprocess
33             mescc:get-host
34             mescc:compile
35             mescc:assemble
36             mescc:link
37             multi-opt))
38
39 (define GUILE-with-output-to-file with-output-to-file)
40 (define (with-output-to-file file-name thunk)
41   (if (equal? file-name "-") (thunk)
42       (GUILE-with-output-to-file file-name thunk)))
43
44 (define (mescc:preprocess options)
45   (let* ((pretty-print/write (string->symbol (option-ref options 'write (if guile? "pretty-print" "write"))))
46          (pretty-print/write (if (eq? pretty-print/write 'pretty-print) pretty-print write))
47          (files (option-ref options '() '("a.c")))
48          (input-file-name (car files))
49          (input-base (basename input-file-name))
50          (ast-file-name (cond ((and (option-ref options 'preprocess #f)
51                                     (option-ref options 'output #f)))
52                               (else (replace-suffix input-base ".E"))))
53          (dir (dirname input-file-name))
54          (defines (reverse (filter-map (multi-opt 'define) options)))
55          (includes (reverse (filter-map (multi-opt 'include) options)))
56          (includes (cons (option-ref options 'includedir #f) includes))
57          (includes (cons dir includes))
58          (prefix (option-ref options 'prefix ""))
59          (machine (option-ref options 'machine "32"))
60          (arch (arch-get options))
61          (defines (cons (arch-get-define options) defines))
62          (verbose? (count-opt options 'verbose)))
63     (with-output-to-file ast-file-name
64       (lambda _ (for-each (cut c->ast prefix defines includes arch pretty-print/write verbose? <>) files)))))
65
66 (define (c->ast prefix defines includes arch write verbose? file-name)
67   (with-input-from-file file-name
68     (cut write (c99-input->ast #:prefix prefix #:defines defines #:includes includes #:arch arch #:verbose? verbose?))))
69
70 (define (mescc:compile options)
71   (let* ((files (option-ref options '() '("a.c")))
72          (input-file-name (car files))
73          (input-base (basename input-file-name))
74          (M1-file-name (cond ((and (option-ref options 'compile #f)
75                                    (option-ref options 'output #f)))
76                              ((string-suffix? ".S" input-file-name) input-file-name)
77                              (else (replace-suffix input-base ".s"))))
78          (infos (map (cut file->info options <>) files))
79          (verbose? (count-opt options 'verbose))
80          (align? (option-ref options 'align #f)))
81     (when verbose?
82       (stderr "dumping: ~a\n" M1-file-name))
83     (with-output-to-file M1-file-name
84       (cut infos->M1 M1-file-name infos #:align? align? #:verbose? verbose?))
85     M1-file-name))
86
87 (define (file->info options file-name)
88   (cond ((.c? file-name) (c->info options file-name))
89         ((.E? file-name) (E->info options file-name))))
90
91 (define (c->info options file-name)
92   (let* ((dir (dirname file-name))
93          (defines (reverse (filter-map (multi-opt 'define) options)))
94          (includes (reverse (filter-map (multi-opt 'include) options)))
95          (includes (cons (option-ref options 'includedir #f) includes))
96          (includes (cons dir includes))
97          (prefix (option-ref options 'prefix ""))
98          (defines (cons (arch-get-define options) defines))
99          (arch (arch-get options))
100          (verbose? (count-opt options 'verbose)))
101     (with-input-from-file file-name
102       (cut c99-input->info (arch-get-info options) #:prefix prefix #:defines defines #:includes includes #:arch arch #:verbose? verbose?))))
103
104 (define (E->info options file-name)
105   (let ((ast (with-input-from-file file-name read))
106         (verbose? (count-opt options 'verbose)))
107     (c99-ast->info (arch-get-info options) ast #:verbose? verbose?)))
108
109 (define (mescc:assemble options)
110   (let* ((files (option-ref options '() '("a.c")))
111          (input-file-name (car files))
112          (input-base (basename input-file-name))
113          (hex2-file-name (cond ((and (option-ref options 'assemble #f)
114                                      (option-ref options 'output #f)))
115                                (else (replace-suffix input-base ".o"))))
116          (s-files (filter .s? files))
117          (hex2-files  M1->hex2 ) ;; FIXME
118          (source-files (filter (disjoin .c? .E?) files))
119          (infos (map (cut file->info options <>) source-files)))
120     (if (and (pair? s-files) (pair? infos))
121         (error "mixing source and object not supported:" source-files s-files))
122     (when (pair? s-files)
123       (M1->hex2 options s-files))
124     (when (pair? infos)
125       (infos->hex2 options hex2-file-name infos))
126     hex2-file-name))
127
128 (define (mescc:link options)
129   (let* ((files (option-ref options '() '("a.c")))
130          (source-files (filter (disjoin .c? .E?) files))
131          (s-files (filter .s? files))
132          (o-files (filter .o? files))
133          (input-file-name (car files))
134          (hex2-file-name (if (or (string-suffix? ".hex2" input-file-name)
135                                  (string-suffix? ".o" input-file-name)) input-file-name
136                                  (replace-suffix input-file-name ".o")))
137          (infos (map (cut file->info options <>) source-files))
138          (s-files (filter .s? files))
139          (hex2-files (filter .o? files))
140          (hex2-files (if (null? s-files) hex2-files
141                          (append hex2-files (list (M1->hex2 options s-files)))))
142          (hex2-files (if (null? infos) hex2-files
143                          (append hex2-files
144                                  (list (infos->hex2 options hex2-file-name infos)))))
145          (default-libraries (if (or (option-ref options 'nodefaultlibs #f)
146                                     (option-ref options 'nostdlib #f)) '()
147                                     '("c")))
148          (libraries (filter-map (multi-opt 'library) options))
149          (libraries (delete-duplicates (append libraries default-libraries)))
150          (hex2-libraries (map (cut find-library options ".a" <>) libraries))
151          (hex2-files (append hex2-files hex2-libraries))
152          (s-files (append s-files (map (cut find-library options ".s" <>)  libraries)))
153          (debug-info? (option-ref options 'debug-info #f))
154          (s-files (if (string-suffix? ".S" input-file-name) s-files
155                       (cons (replace-suffix input-file-name ".s") s-files)))
156          (elf-footer (and debug-info?
157                           (or (M1->blood-elf options s-files)
158                               (exit 1)))))
159     (or (hex2->elf options hex2-files #:elf-footer elf-footer)
160         (exit 1))))
161
162 (define (infos->hex2 options hex2-file-name infos)
163   (let* ((input-file-name (car (option-ref options '() '("a.c"))))
164          (M1-file-name (replace-suffix hex2-file-name ".s"))
165          (options (acons 'compile #t options)) ; ugh
166          (options (acons 'output hex2-file-name options))
167          (verbose? (count-opt options 'verbose))
168          (align? (option-ref options 'align #f)))
169     (when verbose?
170       (stderr "dumping: ~a\n" M1-file-name))
171     (with-output-to-file M1-file-name
172       (cut infos->M1 M1-file-name infos #:align? align?))
173     (or (M1->hex2 options (list M1-file-name))
174         (exit 1))))
175
176 (define (M1->hex2 options M1-files)
177   (let* ((input-file-name (car (option-ref options '() '("a.c"))))
178          (input-base (basename input-file-name))
179          (M1-file-name (car M1-files))
180          (hex2-file-name (cond ((and (option-ref options 'assemble #f)
181                                      (option-ref options 'output #f)))
182                                ((option-ref options 'assemble #f)
183                                 (replace-suffix input-base ".o"))
184                                (else (replace-suffix M1-file-name ".o"))))
185          (verbose? (count-opt options 'verbose))
186          (M1 (or (getenv "M1") "M1"))
187          (command `(,M1
188                     "--LittleEndian"
189                     ,@(arch-get-architecture options)
190                     "-f" ,(arch-find options (arch-get-m1-macros options))
191                     ,@(append-map (cut list "-f" <>) M1-files)
192                     "-o" ,hex2-file-name)))
193     (when (and verbose? (> verbose? 1))
194       (stderr "~a\n" (string-join command)))
195     (and (zero? (apply assert-system* command))
196          hex2-file-name)))
197
198 (define* (hex2->elf options hex2-files #:key elf-footer)
199   (let* ((input-file-name (car (option-ref options '() '("a.c"))))
200          (elf-file-name (cond ((option-ref options 'output #f))
201                               (else "a.out")))
202          (verbose? (count-opt options 'verbose))
203          (hex2 (or (getenv "HEX2") "hex2"))
204          (base-address (option-ref options 'base-address "0x1000000"))
205          (machine (arch-get-machine options))
206          (elf-footer (or elf-footer
207                          (arch-find options (string-append
208                                              "elf" machine "-footer-single-main.hex2"))))
209          (start-files (if (or (option-ref options 'nostartfiles #f)
210                               (option-ref options 'nostdlib #f)) '()
211                               `("-f" ,(arch-find options "crt1.o"))))
212          (command `(,hex2
213                     "--LittleEndian"
214                     ,@(arch-get-architecture options)
215                     "--BaseAddress" ,base-address
216                     "-f" ,(arch-find options (string-append "elf" machine "-header.hex2"))
217                     ,@start-files
218                     ,@(append-map (cut list "-f" <>) hex2-files)
219                     "-f" ,elf-footer
220                     "--exec_enable"
221                     "-o" ,elf-file-name)))
222     (when (and verbose? (> verbose? 1))
223       (stderr "~a\n" (string-join command)))
224     (and (zero? (apply assert-system* command))
225          elf-file-name)))
226
227 (define (M1->blood-elf options M1-files)
228   (let* ((M1-file-name (car M1-files))
229          (M1-blood-elf-footer (string-append M1-file-name ".blood-elf"))
230          (hex2-file-name (replace-suffix M1-file-name ".o"))
231          (blood-elf-footer (string-append hex2-file-name ".blood-elf"))
232          (verbose? (count-opt options 'verbose))
233          (blood-elf (or (getenv "BLOOD_ELF") "blood-elf"))
234          (command `(,blood-elf
235                       "-f" ,(arch-find options (arch-get-m1-macros options))
236                       ,@(append-map (cut list "-f" <>) M1-files)
237                       "-o" ,M1-blood-elf-footer)))
238     (when (and verbose? (> verbose? 1))
239         (format (current-error-port) "~a\n" (string-join command)))
240     (and (zero? (apply assert-system* command))
241          (let* ((options (acons 'compile #t options)) ; ugh
242                 (options (acons 'output blood-elf-footer options)))
243            (M1->hex2 options (list M1-blood-elf-footer))))))
244
245 (define (replace-suffix file-name suffix)
246   (let* ((parts (string-split file-name #\.))
247          (base (if (pair? (cdr parts)) (drop-right parts 1)))
248          (old-suffix (last parts))
249          (program-prefix (cond ((string-prefix? "arm-mes-" old-suffix) ".arm-mes-")
250                                ((string-prefix? "x86-mes-" old-suffix) ".x86-mes-")
251                                ((string-prefix? "x86_64-mes-" old-suffix) ".x86_64-mes-")
252                                (else "."))))
253     (if (string-null? suffix)
254         (if (string-null? program-prefix) (string-join base ".")
255             (string-append (string-drop program-prefix 1) (string-join base ".")))
256         (string-append (string-join base ".") program-prefix (string-drop suffix 1)))))
257
258 (define (find-library options ext o)
259   (arch-find options (string-append "lib" o ext)))
260
261 (define* (arch-find options file-name)
262   (let* ((srcdest (or (getenv "srcdest") ""))
263          (srcdir-lib (string-append srcdest "lib"))
264          (arch (string-append (arch-get options) "-mes"))
265          (path (cons* "."
266                       srcdir-lib
267                       (option-ref options 'libdir "lib")
268                       (filter-map (multi-opt 'library-dir) options)))
269          (arch-file-name (string-append arch "/" file-name))
270          (verbose? (count-opt options 'verbose)))
271     (let ((file (search-path path arch-file-name)))
272       (when (and verbose? (> verbose? 1))
273         (stderr "arch-find=~s\n" arch-file-name)
274         (stderr "     path=~s\n" path)
275         (stderr "  => ~s\n" file))
276       (or file
277           (error (format #f "mescc: file not found: ~s" arch-file-name))))))
278
279 (define (assert-system* . args)
280   (let ((status (apply system* args)))
281     (when (not (zero? status))
282       (stderr "mescc: failed: ~a\n" (string-join args))
283       (exit (status:exit-val status)))
284     status))
285
286 (define (arch-get options)
287   (let* ((machine (option-ref options 'machine #f))
288          (arch (option-ref options 'arch #f)))
289     (if machine (cond ((member arch '("x86" "x86_64")) (cond ((equal? machine "32") "x86")
290                                                              ((equal? machine "64") "x86_64")))
291                       ((equal? arch "arm") (cond ((equal? machine "32") "arm"))))
292         arch)))
293
294 (define (mescc:get-host options)
295   (let ((cpu (arch-get options))
296         (kernel "linux"))
297     (string-join (list cpu kernel "mes") "-")))
298
299 (define (arch-get-info options)
300   (let ((arch (arch-get options)))
301     (cond ((equal? arch "arm") (armv4-info))
302           ((equal? arch "x86") (x86-info))
303           ((equal? arch "x86_64") (x86_64-info)))))
304
305 (define (arch-get-define options)
306   (let ((arch (arch-get options)))
307     (cond ((equal? arch "arm") "__arm__=1")
308           ((equal? arch "x86") "__i386__=1")
309           ((equal? arch "x86_64") "__x86_64__=1"))))
310
311 (define (arch-get-machine options)
312   (let* ((machine (option-ref options 'machine #f))
313          (arch (option-ref options 'arch #f)))
314     (or machine
315         (if (member arch '("x86_64")) "64"
316             "32"))))
317
318 (define (arch-get-m1-macros options)
319   (let ((arch (arch-get options)))
320     (cond ((equal? arch "arm") "arm.M1")
321           ((equal? arch "x86") "x86.M1")
322           ((equal? arch "x86_64") "x86_64.M1"))))
323
324 (define (arch-get-architecture options)
325   (let* ((arch (arch-get options))
326         (numbered-arch? (option-ref options 'numbered-arch? #f))
327         (flag (if numbered-arch? "--Architecture" "--architecture")))
328     (list flag
329           (cond ((equal? arch "arm") (if numbered-arch? "40" "armv7l"))
330                 ((equal? arch "x86") (if numbered-arch? "1" "x86"))
331                 ((equal? arch "x86_64") (if numbered-arch? "2" "amd64"))))))
332
333 (define (multi-opt option-name) (lambda (o) (and (eq? (car o) option-name) (cdr o))))
334 (define (count-opt options option-name)
335   (let ((lst (filter-map (multi-opt option-name) options)))
336     (and (pair? lst) (length lst))))
337
338 (define (.c? o) (or (string-suffix? ".c" o)
339                     (string-suffix? ".M2" o)))
340 (define (.E? o) (or (string-suffix? ".E" o)
341                     (string-suffix? ".mes-E" o)
342                     (string-suffix? ".arm-mes-E" o)
343                     (string-suffix? ".x86-mes-E" o)
344                     (string-suffix? ".x86_64-mes-E" o)))
345 (define (.s? o) (or (string-suffix? ".s" o)
346                     (string-suffix? ".S" o)
347                     (string-suffix? ".mes-S" o)
348                     (string-suffix? ".arm-mes-S" o)
349                     (string-suffix? ".x86-mes-S" o)
350                     (string-suffix? ".x86_64-mes-S" o)
351                     (string-suffix? ".M1" o)))
352 (define (.o? o) (or (string-suffix? ".o" o)
353                     (string-suffix? ".mes-o" o)
354                     (string-suffix? ".arm-mes-o" o)
355                     (string-suffix? ".x86-mes-o" o)
356                     (string-suffix? ".x86_64-mes-o" o)
357                     (string-suffix? ".hex2" o)))