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