mescc: Prepare for x86_64 support.
[mes.git] / module / mescc / mescc.scm
1 ;;; GNU Mes --- Maxwell Equations of Software
2 ;;; Copyright © 2016,2017,2018 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 guile)
25   #:use-module (mes misc)
26
27   #:use-module (mescc i386 info)
28   #:use-module (mescc preprocess)
29   #:use-module (mescc compile)
30   #:use-module (mescc M1)
31   #:export (mescc:preprocess
32             mescc:compile
33             mescc:assemble
34             mescc:link))
35
36 (define %info (x86-info))
37
38 (define GUILE-with-output-to-file with-output-to-file)
39 (define (with-output-to-file file-name thunk)
40   (if (equal? file-name "-") (thunk)
41       (GUILE-with-output-to-file file-name thunk)))
42
43 (define (mescc:preprocess options)
44   (let* ((pretty-print/write (string->symbol (option-ref options 'write (if guile? "pretty-print" "write"))))
45          (pretty-print/write (if (eq? pretty-print/write 'pretty-print) pretty-print write))
46          (files (option-ref options '() '("a.c")))
47          (input-file-name (car files))
48          (ast-file-name (cond ((and (option-ref options 'preprocess #f)
49                                     (option-ref options 'output #f)))
50                               (else (replace-suffix input-file-name ".E"))))
51          (dir (dirname input-file-name))
52          (defines (reverse (filter-map (multi-opt 'define) options)))
53          (includes (reverse (filter-map (multi-opt 'include) options)))
54          (includes (cons dir includes))
55          (prefix (option-ref options 'prefix "")))
56     (with-output-to-file ast-file-name
57       (lambda _ (for-each (cut c->ast prefix defines includes write <>) files)))))
58
59 (define (c->ast prefix defines includes write file-name)
60   (with-input-from-file file-name
61     (cut write (c99-input->ast #:prefix prefix #:defines defines #:includes includes))))
62
63 (define (mescc:compile options)
64   (let* ((files (option-ref options '() '("a.c")))
65          (input-file-name (car files))
66          (M1-file-name (cond ((and (option-ref options 'compile #f)
67                                    (option-ref options 'output #f)))
68                              (else (replace-suffix input-file-name ".S"))))
69          (infos (map (cut file->info options <>) files))
70          (verbose? (option-ref options 'verbose #f)))
71     (when verbose?
72       (stderr "dumping: ~a\n" M1-file-name))
73     (with-output-to-file M1-file-name
74       (cut infos->M1 M1-file-name infos))
75     M1-file-name))
76
77 (define (file->info options file-name)
78   (cond ((.c? file-name) (c->info options file-name))
79         ((.E? file-name) (E->info options file-name))))
80
81 (define (c->info options file-name)
82   (let* ((defines (reverse (filter-map (multi-opt 'define) options)))
83          (includes (reverse (filter-map (multi-opt 'include) options)))
84          (dir (dirname file-name))
85          (includes (cons dir includes))
86          (prefix (option-ref options 'prefix "")))
87     (with-input-from-file file-name
88       (cut c99-input->info %info #:prefix prefix #:defines defines #:includes includes))))
89
90 (define (E->info options file-name)
91   (let ((ast (with-input-from-file file-name read)))
92     (c99-ast->info %info ast)))
93
94 (define (mescc:assemble options)
95   (let* ((files (option-ref options '() '("a.c")))
96          (input-file-name (car files))
97          (hex2-file-name (cond ((and (option-ref options 'assemble #f)
98                                      (option-ref options 'output #f)))
99                                (else (replace-suffix input-file-name ".o"))))
100          (S-files (filter .S? files))
101          (hex2-files  M1->hex2 ) ;; FIXME
102          (source-files (filter (disjoin .c? .E?) files))
103          (infos (map (cut file->info options <>) source-files)))
104     (if (and (pair? S-files) (pair? infos))
105         (error "mixing source and object not supported:" source-files S-files))
106     (when (pair? S-files)
107       (M1->hex2 options S-files))
108     (when (pair? infos)
109       (infos->hex2 options hex2-file-name infos))
110     hex2-file-name))
111
112 (define (mescc:link options)
113   (let* ((files (option-ref options '() '("a.c")))
114          (source-files (filter (disjoin .c? .E?) files))
115          (S-files (filter .S? files))
116          (o-files (filter .o? files))
117          (input-file-name (car files))
118          (hex2-file-name (if (or (string-suffix? ".hex2" input-file-name)
119                                  (string-suffix? ".o" input-file-name)) input-file-name
120                                  (replace-suffix input-file-name ".o")))
121          (infos (map (cut file->info options <>) source-files))
122          (S-files (filter .S? files))
123          (hex2-files (filter .o? files))
124          (hex2-files (if (null? S-files) hex2-files
125                          (append hex2-files (list (M1->hex2 options S-files)))))
126          (hex2-files (if (null? infos) hex2-files
127                          (append hex2-files
128                                  (list (infos->hex2 options hex2-file-name infos)))))
129          (libraries (filter-map (multi-opt 'library) options))
130          (libraries (if (pair? libraries) libraries '("c")))
131          (libraries (if (equal? libraries '("none")) '() libraries))
132          (hex2-libraries (map (cut find-library options ".o" <>) libraries))
133          (hex2-files (append hex2-files hex2-libraries))
134          (S-files (append S-files (map (cut find-library options ".S" <>)  libraries)))
135          (debug-info? (option-ref options 'debug-info #f))
136          (S-files (cons (replace-suffix input-file-name ".S") S-files))
137          (elf-footer (and debug-info?
138                           (or (M1->blood-elf options S-files)
139                               (exit 1)))))
140     (or (hex2->elf options hex2-files #:elf-footer elf-footer)
141         (exit 1))))
142
143 (define (infos->hex2 options hex2-file-name infos)
144   (let* ((input-file-name (car (option-ref options '() '("a.c"))))
145          (M1-file-name (replace-suffix hex2-file-name ".S"))
146          (options (acons 'compile #t options)) ; ugh
147          (options (acons 'output hex2-file-name options))
148          (verbose? (option-ref options 'verbose #f)))
149     (when verbose?
150       (stderr "dumping: ~a\n" M1-file-name))
151     (with-output-to-file M1-file-name
152       (cut infos->M1 M1-file-name infos))
153     (or (M1->hex2 options (list M1-file-name))
154         (exit 1))))
155
156 (define (M1->hex2 options M1-files)
157   (let* ((input-file-name (car (option-ref options '() '("a.c"))))
158          (M1-file-name (car M1-files))
159          (hex2-file-name (cond ((and (option-ref options 'assemble #f)
160                                      (option-ref options 'output #f)))
161                                ((option-ref options 'assemble #f)
162                                 (replace-suffix input-file-name ".o"))
163                                (else (replace-suffix M1-file-name ".o"))))
164          (verbose? (option-ref options 'verbose #f))
165          (M1 (or (getenv "M1") "M1"))
166          (command `(,M1
167                     "--LittleEndian"
168                     "--Architecture" "1"
169                     "-f" ,(arch-find options "x86.M1")
170                     ,@(append-map (cut list "-f" <>) M1-files)
171                     "-o" ,hex2-file-name)))
172     (when verbose?
173       (stderr "~a\n" (string-join command)))
174     (and (zero? (apply assert-system* command))
175          hex2-file-name)))
176
177 (define* (hex2->elf options hex2-files #:key elf-footer)
178   (let* ((input-file-name (car (option-ref options '() '("a.c"))))
179          (elf-file-name (cond ((option-ref options 'output #f))
180                               (else (replace-suffix input-file-name ""))))
181          (verbose? (option-ref options 'verbose #f))
182          (elf-footer (or elf-footer (arch-find options "elf32-footer-single-main.hex2")))
183          (hex2 (or (getenv "HEX2") "hex2"))
184          (command `(,hex2
185                     "--LittleEndian"
186                     "--Architecture" "1"
187                     "--BaseAddress" "0x1000000"
188                     "-f" ,(arch-find options "elf32-header.hex2")
189                     "-f" ,(arch-find options "crt1.o")
190                     ,@(append-map (cut list "-f" <>) hex2-files)
191                     "-f" ,elf-footer
192                     "--exec_enable"
193                     "-o" ,elf-file-name)))
194     (when verbose?
195       (stderr "~a\n" (string-join command)))
196     (and (zero? (apply assert-system* command))
197          elf-file-name)))
198
199 (define (M1->blood-elf options M1-files)
200   (let* ((M1-file-name (car M1-files))
201          (M1-blood-elf-footer (string-append M1-file-name ".blood-elf"))
202          (hex2-file-name (replace-suffix M1-file-name ".o"))
203          (blood-elf-footer (string-append hex2-file-name ".blood-elf"))
204          (verbose? (option-ref options 'verbose #f))
205          (blood-elf (or (getenv "BLOOD_ELF") "blood-elf"))
206          (command `(,blood-elf
207                       "-f" ,(arch-find options "x86.M1")
208                       ,@(append-map (cut list "-f" <>) M1-files)
209                       "-o" ,M1-blood-elf-footer)))
210     (when verbose?
211         (format (current-error-port) "~a\n" (string-join command)))
212     (and (zero? (apply assert-system* command))
213          (let* ((options (acons 'compile #t options)) ; ugh
214                 (options (acons 'output blood-elf-footer options)))
215            (M1->hex2 options (list M1-blood-elf-footer))))))
216
217 (define (replace-suffix file-name suffix)
218   (let* ((parts (string-split file-name #\.))
219          (base (if (pair? (cdr parts)) (drop-right parts 1))))
220     (string-append (string-join base ".") suffix)))
221
222 (define (find-library options ext o)
223   (arch-find options (string-append "lib" o ext)))
224
225 (define* (arch-find options file-name)
226   (let* ((srcdest (or (getenv "srcdest") ""))
227          (srcdir-lib (string-append srcdest "lib"))
228          (path (cons* srcdir-lib
229                       (prefix-file options "lib")
230                       (filter-map (multi-opt 'library-dir) options)))
231          (arch-file-name (string-append "x86-mes/" file-name))
232          (verbose? (option-ref options 'verbose #f)))
233     (when verbose?
234       (stderr "arch-find=~s\n" arch-file-name)
235       (stderr "     path=~s\n" path)
236       (stderr "  => ~s\n" (search-path path arch-file-name)))
237     (search-path path arch-file-name)))
238
239 (define (prefix-file options file-name)
240   (let ((prefix (option-ref options 'prefix "")))
241     (define (prefix-file o)
242       (if (string-null? prefix) o (string-append prefix "/" o)))
243     (prefix-file file-name)))
244
245 (define (assert-system* . args)
246   (let ((status (apply system* args)))
247     (when (not (zero? status))
248       (stderr "mescc: failed: ~a\n" (string-join args))
249       (exit status))
250     status))
251
252 (define (multi-opt option-name) (lambda (o) (and (eq? (car o) option-name) (cdr o))))
253
254 (define (.c? o) (or (string-suffix? ".c" o)
255                     (string-suffix? ".M2" o)))
256 (define (.E? o) (string-suffix? ".E" o))
257 (define (.S? o) (or (string-suffix? ".S" o)
258                     (string-suffix? ".mes-S" o)
259                     (string-suffix? "S" o)
260                     (string-suffix? ".M1" o)))
261 (define (.o? o) (or (string-suffix? ".o" o)
262                     (string-suffix? ".mes-o" o)
263                     (string-suffix? "o" o)
264                     (string-suffix? ".hex2" o)))