7388bec53e7491bdcc7bb5a8c2930efe972a2ca7
[mes.git] / module / language / c99 / compiler.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,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 ;;; compiler.mes produces an i386 binary from the C produced by
24 ;;; Nyacc c99.
25
26 ;;; Code:
27
28 (cond-expand
29  (guile-2
30   (set-port-encoding! (current-output-port) "ISO-8859-1"))
31  (guile)
32  (mes
33   (mes-use-module (nyacc lang c99 parser))
34   (mes-use-module (mes elf-util))
35   (mes-use-module (mes pmatch))
36   (mes-use-module (mes elf))
37   (mes-use-module (mes libc-i386))
38   (mes-use-module (mes optargs))))
39
40 (define (logf port string . rest)
41   (apply format (cons* port string rest))
42   (force-output port)
43   #t)
44
45 (define (stderr string . rest)
46   (apply logf (cons* (current-error-port) string rest)))
47
48 (define (gnuc-xdef? name mode) (if (equal? name "__GNUC__") #f (eq? mode 'code)))
49
50 (define (mescc)
51   (parse-c99
52    #:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
53    #:cpp-defs '(
54                 ("__GNUC__" . "0")
55                 ("__NYACC__" . "1")
56                 ("VERSION" . "0.4")
57                 ("PREFIX" . "")
58                 )
59    #:xdef? gnuc-xdef?
60    #:mode 'code
61    ))
62
63 (define (write-any x)
64   (write-char (cond ((char? x) x)
65                     ((number? x) (integer->char (if (>= x 0) x (+ x 256))))
66                     (else (stderr "write-any: ~a\n" x) barf))))
67
68 (define (ast:function? o)
69   (and (pair? o) (eq? (car o) 'fctn-defn)))
70
71 (define (.name o)
72   (pmatch o
73     ((fctn-defn _ (ftn-declr (ident ,name) _) _) name)
74     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) _) name)
75     ((param-decl _ (param-declr (ident ,name))) name)
76     ((param-decl _ (param-declr (ptr-declr (pointer) (ident ,name)))) name)
77     ((param-decl _ (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) name)
78     (_
79      (format (current-error-port) "SKIP .name =~a\n" o))))
80
81 (define (.statements o)
82   (pmatch o
83     ((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
84     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)))
85
86 (define <info> '<info>)
87 (define <functions> '<functions>)
88 (define <globals> '<globals>)
89 (define <locals> '<locals>)
90 (define <text> '<text>)
91 (define* (make o #:key (functions '()) (globals '()) (locals '()) (text '()))
92   (pmatch o
93     (<info> (list <info>
94                   (cons <functions> functions)
95                   (cons <globals> globals)
96                   (cons <locals> locals)
97                   (cons <text> text)))))
98
99 (define (.functions o)
100   (pmatch o
101     ((<info> . ,alist) (assq-ref alist <functions>))))
102
103 (define (.globals o)
104   (pmatch o
105     ((<info> . ,alist) (assq-ref alist <globals>))))
106
107 (define (.locals o)
108   (pmatch o
109     ((<info> . ,alist) (assq-ref alist <locals>))))
110
111 (define (.text o)
112   (pmatch o
113     ((<info> . ,alist) (assq-ref alist <text>))))
114
115 (define (info? o)
116   (and (pair? o) (eq? (car o) <info>)))
117
118 (define (clone o . rest)
119   (cond ((info? o)
120          (let ((functions (.functions o))
121                (globals (.globals o))
122                (locals (.locals o))
123                (text (.text o)))
124            (let-keywords rest
125                          #f
126                          ((functions functions)
127                           (globals globals)
128                           (locals locals)
129                           (text text))
130                          (make <info> #:functions functions #:globals globals #:locals locals #:text text))))))
131
132 (define (ref-local locals)
133   (lambda (o)
134     ;; (stderr "IDENT REF[~a]: ~a => ~a\n" o (assoc-ref locals o) (i386:ref-local (assoc-ref locals o)))
135     (i386:ref-local (assoc-ref locals o))))
136
137 (define (ref-global globals)
138   (lambda (o)
139     (lambda (f g t d)
140       (i386:ref-global (+ (data-offset o g;;lobals
141                                        ) d)))))
142
143 (define (expr->arg globals locals) ;; FIXME: get Mes curried-definitions
144   (lambda (o)
145     (pmatch o
146       ((p-expr (fixed ,value)) (string->number value))
147       ((p-expr (string ,string)) ((ref-global globals) string))
148       ((p-expr (ident ,name)) ((ref-local locals) name))
149
150       ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
151        (let ((value (string->number value))
152              (size 4)) ;; FIXME: type: int
153          (lambda (f g t d)
154            (append
155             ((ident->base locals) name)
156             (i386:value->accu (* size value)) ;; FIXME: type: int
157             (i386:mem->accu) ;; FIXME: type: int
158             (i386:push-accu) ;; hmm
159             ))))
160
161       (_
162        (format (current-error-port) "SKIP expr->arg=~a\n" o)     
163        0))))
164
165 (define (ident->accu locals)
166   (lambda (o)
167     (i386:local->accu (assoc-ref locals o))))
168
169 (define (accu->ident locals)
170   (lambda (o)
171     (i386:accu->local (assoc-ref locals o))))
172
173 (define (ident->base locals)
174   (lambda (o)
175     (i386:local->base (assoc-ref locals o))))
176
177 (define (expr->accu info)
178   (lambda (o)
179     (pmatch o
180       ((p-expr (fixed ,value)) (string->number value))
181       ((p-expr (ident ,name)) ((ident->accu (.locals info)) name))
182       (_
183        (format (current-error-port) "SKIP expr-accu=~a\n" o)
184        0)
185       )))
186
187 (define (string->global string)
188   (cons string (append (string->list string) (list #\nul))))
189
190 (define (expr->global o)
191   (pmatch o
192     ((p-expr (string ,string)) (string->global string))
193     (_ #f)))
194
195 (define (dec->hex o)
196   (number->string o 16))
197
198 (define (byte->hex o)
199   (string->number (string-drop o 2) 16))
200
201 (define (asm->hex o)
202   (let ((prefix ".byte "))
203     (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~a\n" o)'())
204         (let ((s (string-drop o (string-length prefix))))
205           (map byte->hex (string-split s #\space))))))
206
207 (define (ast->info info)
208   (lambda (o)
209     (let ((globals (.globals info))
210           (locals (.locals info))
211           (text (.text info)))
212       (define (add-local name)
213          (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals))
214
215       ;; (stderr "S=~a\n" o)
216       ;; (stderr "   info=~a\n" info)
217       ;; (stderr "   globals=~a\n" globals)
218       (pmatch o
219         (((trans-unit . _) . _) ((ast-list->info info) o))
220         ((trans-unit . ,elements) ((ast-list->info info) elements))
221         ((fctn-defn . _) ((function->info info) o))
222         ((comment . _) info)
223         ((cpp-stmt (define (name ,name) (repl ,value)))
224          (stderr "SKIP: #define ~a ~a\n" name value)
225          info)
226
227         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
228         
229         ((expr-stmt (fctn-call (p-expr (ident ,name))
230                                (expr-list (p-expr (string ,string)))))
231          ;;(stderr "S1 string=~a\n" string)
232          (if (equal? name "asm") (clone info #:text (append text (list (lambda (f g t d) (asm->hex string)))))
233              (let ((globals (append globals (list (string->global string)))))
234                (clone info #:text
235                       (append text (list (lambda (f g t d)
236                                            (i386:call f g t d
237                                                       (+ t (function-offset name f))
238                                                       (+ d (data-offset string g))))))
239                       #:globals globals))))
240         
241         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
242          ;;(stderr "S1 expr-list=~a\n" expr-list)
243          (let* ((globals (append globals (filter-map expr->global expr-list)))
244                 (args (map (expr->arg globals locals) expr-list)))
245            (clone info #:text
246                   (append text (list (lambda (f g t d)
247                                        (apply i386:call (cons* f g t d
248                                                                (+ t (function-offset name f)) args)))))
249                   #:globals globals)))
250
251         ((if (gt (p-expr (ident ,name)) (p-expr (fixed ,value))) ,body)
252          (let* ((value (string->number value))
253                 (info (clone info #:text '()))
254                 (body-info ((ast->info info) body))
255                 (body-text (.text body-info))
256                 (body-length (length (text->list body-text))))
257
258            (clone info #:text
259                   (append text
260                           (list (lambda (f g t d)
261                                   (append
262                                    (i386:local-test (assoc-ref locals name) value)
263                                    (i386:jump-le body-length))))
264                           body-text)
265                   #:globals (.globals body-info))))
266
267         (;;(for ,init ,test ,step ,body)
268          (for ,init
269               ;; FIXME: ,test
270               (lt (p-expr (ident ,name)) (p-expr (fixed ,value)))
271               ,step ,body)
272          (let* ((value (string->number value))
273                 (info (clone info #:text '()))
274
275                 (info ((ast->info info) init))
276
277                 (init-text (.text info))
278                 (init-locals (.locals info))
279                 (info (clone info #:text '()))
280
281                 (body-info ((ast->info info) body))
282                 (body-text (.text body-info))
283                 (body-length (length (text->list body-text)))
284
285                 (step-info ((ast->info info) `(expr-stmt ,step)))
286                 (step-text (.text step-info))
287                 (step-length (length (text->list step-text)))
288
289                 ;; (test-info ((ast->info info) test))
290                 ;; (test-text (.text test-info))
291                 ;; (test-length (length (text->list test-text)))
292                 )
293
294            (clone info #:text
295                   (append text
296                           init-text
297                           (list (lambda (f g t d) (i386:jump body-length)))
298                           body-text
299                           step-text
300                           ;;test-text
301                           ;;(list (lambda (f g t d) (i386:jump-nz (- (+ body-length test-length)))))
302                           (list (lambda (f g t d)
303                                   (append
304                                    (i386:local-test (assoc-ref init-locals name) value)
305                                    (i386:jump-le (- (+ body-length step-length 2) ;;test-length
306                                                     )))))
307                           )
308                   #:globals (append globals (.globals body-info))
309                   #:locals locals)))
310
311         ((while ,test ,body)
312          (let* ((info (clone info #:text '()))
313                 (body-info ((ast->info info) body))
314                 (body-text (.text body-info))
315                 (body-length (length (text->list body-text)))
316
317                 (test-info ((ast->info info) test))
318                 (test-text (.text test-info))
319                 (test-length (length (text->list test-text))))
320
321            (clone info #:text
322                   (append text
323                           (list (lambda (f g t d) (i386:jump body-length)))
324                           body-text
325                           test-text
326                           (list (lambda (f g t d) (i386:jump-nz (- (+ body-length test-length))))))
327                   #:globals (.globals body-info))))
328
329         ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
330          (let ((value (string->number value)))
331            (clone info #:text
332                   (append text (list (lambda (f g t d)
333                                        (append
334                                         ((ident->base locals) name)
335                                         (i386:value->accu value)
336                                         (i386:mem-byte->accu)))))))) ; FIXME: type: char
337         
338         ((array-ref (p-expr (ident ,name)) (p-expr (ident ,index)))
339          (clone info #:text
340                 (append text (list (lambda (f g t d)
341                                      (append
342                                       ((ident->base locals) name)
343                                       ((ident->accu locals) index)
344                                       (i386:mem-byte->accu))))))) ; FIXME: type: char
345         
346         ;; i++
347         ((expr-stmt (post-inc (p-expr (ident ,name))))
348          (clone info #:text
349                 (append text (list (lambda (f g t d)
350                                      (i386:local-add (assoc-ref locals name) 1))))))
351
352         ;; ++i -- same for now FIXME
353         ((expr-stmt (pre-inc (p-expr (ident ,name))))
354          (clone info #:text
355                 (append text (list (lambda (f g t d)
356                                      (i386:local-add (assoc-ref locals name) 1))))))
357
358         ((return ,expr)
359          (clone info #:text
360                 (append text (list (i386:ret ((expr->accu info) expr))))))
361
362         ;; int i;
363         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
364          (clone info #:locals (add-local name)))
365
366         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
367          (let ((locals (add-local name)))
368            (let ((value (string->number value)))
369              (clone info #:text
370                     (append text (list (lambda (f g t d)
371                                        (i386:local-assign (assoc-ref locals name) value))))
372                   #:locals locals))))
373
374         ;; int i = argc;
375         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
376          (let ((locals (add-local name)))
377           (clone info #:text
378                  (append text (list (lambda (f g t d)
379                                       (append
380                                        ((ident->accu locals) local)
381                                        ((accu->ident locals) name)))))
382                  #:locals locals)))
383
384         ;; SCM i = argc;
385         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
386          (let ((locals (add-local name)))
387            (clone info #:text
388                 (append text (list (lambda (f g t d)
389                                      (append
390                                       ((ident->accu locals) local)
391                                       ((accu->ident locals) name)))))
392                 #:locals locals)))
393         
394         ;; int i = f ();
395         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
396          (let* ((locals (add-local name))
397                 (info (clone info #:locals locals)))
398            (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
399              (clone info
400                     #:text
401                     (append (.text info)
402                             (list (lambda (f g t d)
403                                     (i386:ret-local (assoc-ref locals name)))))
404                     #:locals locals))))
405         
406         ;; i = 0;
407         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value))))
408          ;;(stderr "RET LOCAL[~a]: ~a\n" name (assoc-ref locals name))
409          (let ((value (string->number value)))
410            (clone info #:text (append text (list (lambda (f g t d) (i386:local-assign (assoc-ref locals name) value)))))))
411         
412         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (fctn-call . ,call)))
413          (let* ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
414            (clone info #:text (append (.text info) (list (lambda (f g t d) (i386:ret-local (assoc-ref locals name))))))))
415
416         (_
417          (format (current-error-port) "SKIP statement=~a\n" o)
418          info)))))
419
420 (define (info->exe info)
421   (display "dumping elf\n" (current-error-port))
422   (map write-any (make-elf (.functions info) (.globals info))))
423
424 (define (.formals o)
425   (pmatch o
426     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
427     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
428     (_ (format (current-error-port) ".formals: no match: ~a\n" o)
429        barf)))
430
431 (define (formal->text n)
432   (lambda (o i)
433     ;;(i386:formal i n)
434     '()
435     ))
436
437 (define (formals->text o)
438   (pmatch o
439     ((param-list . ,formals)
440      (let ((n (length formals)))
441        (list (lambda (f g t d)
442                (append
443                 (i386:function-preamble)
444                 (append-map (formal->text n) formals (iota n))
445                 (i386:function-locals))))))
446     (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
447        barf)))
448
449 (define (formals->locals o)
450   (pmatch o
451     ((param-list . ,formals)
452      (let ((n (length formals)))
453        ;;(stderr "FORMALS: ~a ==> ~a\n" formals n)
454        (map cons (map .name formals) (iota n -2 -1))))
455     (_ (format (current-error-port) "formals->info: no match: ~a\n" o)
456        barf)))
457
458 (define (function->info info)
459   (lambda (o)
460     ;;(stderr "\n")
461     (format (current-error-port) "compiling ~a\n" (.name o))
462     ;;(stderr "formals=~a\n" (.formals o))
463     (let* ((text (formals->text (.formals o)))
464            (locals (formals->locals (.formals o))))
465       ;;(stderr "locals=~a\n" locals)
466       (let loop ((statements (.statements o))
467                  (info (clone info #:locals locals #:text text)))
468         (if (null? statements) (clone info
469                                       #:functions (append (.functions info) (list (cons (.name o) (.text info)))))
470             (let* ((statement (car statements)))
471               (loop (cdr statements) ((ast->info info) (car statements)))))))))
472
473 (define (ast-list->info info)
474   (lambda (elements)
475     (let loop ((elements elements) (info info))
476       (if (null? elements) info
477           (loop (cdr elements) ((ast->info info) (car elements)))))))
478
479 (define _start
480   (let* ((argc-argv
481           (string-append ".byte"
482                          " 0x89 0xe8"      ; mov    %ebp,%eax
483                          " 0x83 0xc0 0x08" ; add    $0x8,%eax
484                          " 0x50"           ; push   %eax
485                          " 0x89 0xe8"      ; mov    %ebp,%eax
486                          " 0x83 0xc0 0x04" ; add    $0x4,%eax
487                          " 0x0f 0xb6 0x00" ; movzbl (%eax),%eax
488                          " 0x50"           ; push   %eax
489                          ))
490          (ast (with-input-from-string
491                   
492                   (string-append "int _start () {int i;asm(\"" argc-argv "\");i=main ();exit (i);}")
493                 parse-c99)))
494     ast))
495
496 (define strlen
497   (let* ((ast (with-input-from-string
498                   "
499 int
500 strlen (char const* s)
501 {
502   int i = 0;
503   while (s[i]) i++;
504   return i;
505 }
506 "
507 ;;paredit:"
508                 parse-c99)))
509     ast))
510
511 (define eputs
512   (let* ((ast (with-input-from-string
513                   "
514 int
515 eputs (char const* s)
516 {
517   //write (STDERR, s, strlen (s));
518   //write (2, s, strlen (s));
519   int i = strlen (s);
520   write (2, s, i);
521   return 0;
522 }
523 "
524 ;;paredit:"
525                 parse-c99)))
526     ast))
527
528 (define fputs
529   (let* ((ast (with-input-from-string
530                   "
531 int
532 fputs (char const* s, int fd)
533 {
534  int i = strlen (s);
535   write (fd, s, i);
536   return 0;
537 }
538 "
539 ;;paredit:"
540                 parse-c99)))
541     ast))
542
543 (define puts
544   (let* ((ast (with-input-from-string
545                   "
546 int
547 puts (char const* s)
548 {
549   //write (STDOUT, s, strlen (s));
550   //int i = write (STDOUT, s, strlen (s));
551   int i = strlen (s);
552   write (1, s, i);
553   return 0;
554 }
555 "
556 ;;paredit:"
557                 parse-c99)))
558     ast))
559
560 (define i386:libc
561   (list
562    (cons "exit" (list i386:exit))
563    (cons "write" (list i386:write))))
564
565 (define libc
566   (list
567    strlen
568    eputs
569    fputs
570    puts))
571
572 (define (compile)
573   (let* ((ast (mescc))
574          (info (make <info> #:functions i386:libc))
575          (info ((ast->info info) libc))
576          (info ((ast->info info) ast))
577          (info ((ast->info info) _start)))
578     (info->exe info)))