mes/module/language/c99/compiler.mes
Jan Nieuwenhuizen 296449c615 mescc: Have micro-mes print argv.
* module/language/c99/compiler.mes (expr->arg): Bugfix argv: Use
  size=4 (int).
  (statement->text+symbols+locals): Bugfixes: array-ref, initialize with
  immediate, initialize with local.
  (formals->locals): Bugfix: formals counted down from -1 [WAS: down to
  -1].
* module/mes/libc-i386.mes (i386:call): Reverse args pushes to match
  formals index changes.
  (i386:write): Update for changed formals push order.
  (i386:mem->accu, i386:value->accu): New functions.
* module/mes/libc-i386.scm (mes): Export them.
* doc/examples/micro-mes.c (eputs, puts, fputs): Make identical with
  mescc's implementations.
  (main): Print argv[0] and (unconditionally; crash if not given) argv[1].
2017-01-03 12:33:34 +01:00

518 lines
18 KiB
Scheme

;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; compiler.mes produces an i386 binary from the C produced by
;;; Nyacc c99.
;;; Code:
(cond-expand
(guile-2
(set-port-encoding! (current-output-port) "ISO-8859-1"))
(guile)
(mes
(mes-use-module (nyacc lang c99 parser))
(mes-use-module (mes elf-util))
(mes-use-module (mes pmatch))
(mes-use-module (mes elf))
(mes-use-module (mes libc-i386))))
(define (logf port string . rest)
(apply format (cons* port string rest))
(force-output port)
#t)
(define (stderr string . rest)
(apply logf (cons* (current-error-port) string rest)))
(define (gnuc-xdef? name mode) (if (equal? name "__GNUC__") #f (eq? mode 'code)))
;;(define (gnuc-xdef? name mode) (equal? name "__GNUC__"))
;; (define (gnuc-xdef? name mode)
;; (cond ((equal? name "__GNUC__") #t)
;; ((equal? name "asm") #f)))
(define (mescc)
(parse-c99 #:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
#:cpp-defs '(("__GNUC__" . "0") ("__NYACC__" . "1"))
#:xdef? gnuc-xdef?
#:mode 'code
))
(define (write-any x)
(write-char (if (char? x) x (integer->char (if (>= x 0) x (+ x 256))))))
(define (ast:function? o)
(and (pair? o) (eq? (car o) 'fctn-defn)))
(define (.name o)
(pmatch o
((fctn-defn _ (ftn-declr (ident ,name) _) _) name)
((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) _) name)
((param-decl _ (param-declr (ident ,name))) name)
((param-decl _ (param-declr (ptr-declr (pointer) (ident ,name)))) name)
((param-decl _ (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) name)
(_
(format (current-error-port) "SKIP .name =~a\n" o))))
(define (.statements o)
(pmatch o
((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)))
(define (ident-ref locals)
(lambda (o)
;; (stderr "IDENT REF[~a]: ~a => ~a\n" o (assoc-ref locals o) (i386:ref-local (assoc-ref locals o)))
(i386:ref-local (assoc-ref locals o))))
(define (global-ref symbols)
(lambda (o)
(lambda (s t d)
(i386:ref-global (+ (data-offset o symbols) d)))))
(define (expr->arg symbols locals) ;; FIXME: get Mes curried-definitions
(lambda (o)
(pmatch o
((p-expr (fixed ,value)) (string->number value))
((p-expr (string ,string)) ((global-ref symbols) string))
((p-expr (ident ,name)) ((ident-ref locals) name))
((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
(let ((value (string->number value))
(size 4)) ;; FIXME: type: int
(lambda (s t d)
(append
((ident->base locals) name)
(i386:value->accu (* size value)) ;; FIXME: type: int
(i386:mem->accu) ;; FIXME: type: int
(i386:push-accu) ;; hmm
))))
(_
(format (current-error-port) "SKIP expr->arg=~a\n" o)
0))))
(define (ident->accu locals)
(lambda (o)
(i386:local->accu (assoc-ref locals o))))
(define (accu->ident locals)
(lambda (o)
(i386:accu->local (assoc-ref locals o))))
(define (ident->base locals)
(lambda (o)
(i386:local->base (assoc-ref locals o))))
;; (define (global-accu symbols)
;; (lambda (o)
;; (lambda (s t d)
;; (i386:accu-global (+ (data-offset o symbols) d)))))
(define (expr->accu symbols locals)
(lambda (o)
(pmatch o
((p-expr (fixed ,value)) (string->number value))
((p-expr (ident ,name)) ((ident->accu locals) name))
(_
(format (current-error-port) "SKIP expr-accu=~a\n" o)
0)
)))
(define (expr->symbols o)
(pmatch o
((p-expr (string ,string)) (string->symbols string))
(_ #f)))
(define make-text+symbols+locals cons*)
(define .text car)
(define .symbols cadr)
(define .locals cddr)
(define (dec->hex o)
(number->string o 16))
(define (text->list o)
(append-map (lambda (f) (f '() 0 0)) o))
(define (byte->hex o)
(string->number (string-drop o 2) 16))
(define (asm->hex o)
(let ((prefix ".byte "))
(if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~a\n" o)'())
(let ((s (string-drop o (string-length prefix))))
(map byte->hex (string-split s #\space))))))
(define (statement->text+symbols+locals text+symbols+locals)
(lambda (o)
;;(stderr "S=~a\n" o)
(let* ((text (.text text+symbols+locals))
(symbols (.symbols text+symbols+locals))
(locals (.locals text+symbols+locals))
(text-list (text->list text))
(prefix-list (symbols->text symbols 0 0))
(statement-offset (- (+ (length prefix-list) (length text-list)))))
;; (stderr " tsl=~a\n" text+symbols+locals)
;; (stderr " locals=~s\n" locals)
(pmatch o
((expr-stmt (fctn-call (p-expr (ident ,name))
(expr-list (p-expr (string ,string)))))
;;(stderr "S1 string=~a\n" string)
(if (equal? name "asm")
(make-text+symbols+locals
(append
text
(list (lambda (s t d) (asm->hex string))))
symbols
locals)
(make-text+symbols+locals
(append text
(list (lambda (s t d)
(i386:call s t d
(+ t (function-offset name s)
statement-offset)
(+ d (data-offset string s))))))
(append symbols (list (string->symbols string)))
locals)))
((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
;;(stderr "S1 expr-list=~a\n" expr-list)
(let* ((symbols (append symbols (filter-map expr->symbols expr-list)))
(args (map (expr->arg symbols locals) expr-list)))
(make-text+symbols+locals
(append text
(list (lambda (s t d) (apply i386:call (cons* s t d (+ t (function-offset name s) statement-offset) args)))))
symbols
locals)))
((while ,test ,body)
(let* ((t+s+l (make-text+symbols+locals '() symbols locals))
(body-t+s+l ((statement->text+symbols+locals t+s+l) body))
(body-text (.text body-t+s+l))
;;(body-symbols (.symbols body-t+s+l))
(symbols (.symbols body-t+s+l))
(body-locals (.locals body-t+s+l))
(body-length (length (text->list body-text)))
(test-t+s+l ((statement->text+symbols+locals t+s+l) test))
(test-text (.text test-t+s+l))
(test-symbols (.symbols test-t+s+l))
(test-locals (.locals test-t+s+l))
(test-length (length (text->list test-text))))
(make-text+symbols+locals
(append text
(list (lambda (s t d) (i386:jump body-length)))
body-text
test-text
(list (lambda (s t d) (i386:test-jump (- (+ body-length test-length))))))
symbols
locals)))
((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
(let ((value (string->number value)))
(make-text+symbols+locals
(append
text
(list
(lambda (s t d)
(append
((ident->base locals) name)
(i386:value->accu value)
(i386:mem-byte->accu))))) ; FIXME: type: char
symbols
locals)))
((array-ref (p-expr (ident ,name)) (p-expr (ident ,index)))
(make-text+symbols+locals
(append
text
(list
(lambda (s t d)
(append
((ident->base locals) name)
((ident->accu locals) index)
(i386:mem-byte->accu))))) ; FIXME: type: char
symbols
locals))
((expr-stmt (post-inc (p-expr (ident ,name))))
(make-text+symbols+locals
(append text
(list (lambda (s t d) (i386:local-add (assoc-ref locals name) 1))))
symbols
locals))
((return ,expr)
(make-text+symbols+locals
(append text (list (i386:ret ((expr->accu symbols locals) expr))))
symbols
locals))
;; int i;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
(let ((locals (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals)))
(make-text+symbols+locals text symbols locals)))
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
(let ((locals (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals))
(value (string->number value)))
(make-text+symbols+locals
(append
text
(list (lambda (s t d) (i386:local-assign (assoc-ref locals name) value))))
symbols
locals)))
;; int i = argc;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
(let ((locals (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals)))
(make-text+symbols+locals
(append
text
(list (lambda (s t d)
(append
((ident->accu locals) local)
((accu->ident locals) name)))))
symbols
locals)))
;; SCM i = argc;
((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
(let ((locals (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals)))
(make-text+symbols+locals
(append
text
(list (lambda (s t d)
(append
((ident->accu locals) local)
((accu->ident locals) name)))))
symbols
locals)))
;; int i = f ();
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
(let ((locals (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals)))
(let* ((t+s+l (make-text+symbols+locals text symbols locals))
(t+s+l ((statement->text+symbols+locals t+s+l)
`(expr-stmt (fctn-call ,@call))))
(text (.text t+s+l))
(symbols (.symbols t+s+l))
(locals (.locals t+s+l)))
(make-text+symbols+locals
(append
text
(list (lambda (s t d) (i386:ret-local (assoc-ref locals name)))))
symbols
locals))))
;; i = 0;
((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value))))
;;(stderr "RET LOCAL[~a]: ~a\n" name (assoc-ref locals name))
(let ((value (string->number value)))
(make-text+symbols+locals
(append text (list (lambda (s t d) (i386:local-assign (assoc-ref locals name) value))))
symbols
locals)))
((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (fctn-call . ,call)))
(let* ((t+s+l ((statement->text+symbols+locals text+symbols+locals)
`(expr-stmt (fctn-call ,@call))))
(text (.text t+s+l))
(symbols (.symbols t+s+l))
(locals (.locals t+s+l)))
(make-text+symbols+locals
(append text (list (lambda (s t d) (i386:ret-local (assoc-ref locals name)))))
symbols
locals)))
(_
(format (current-error-port) "SKIP statement=~a\n" o)
text+symbols+locals)))))
(define (symbols->exe symbols)
(display "dumping elf\n" (current-error-port))
(map write-any (make-elf symbols)))
(define (.formals o)
(pmatch o
((fctn-defn _ (ftn-declr _ ,formals) _) formals)
((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
(_ (format (current-error-port) ".formals: no match: ~a\n" o)
barf)))
(define (formal->text n)
(lambda (o i)
;;(i386:formal i n)
'()
))
(define (formals->text o)
(pmatch o
((param-list . ,formals)
(let ((n (length formals)))
(list (lambda (s t d)
(append
(i386:function-preamble)
(append-map (formal->text n) formals (iota n))
(i386:function-locals))))))
(_ (format (current-error-port) "formals->text: no match: ~a\n" o)
barf)))
(define (formals->locals o)
(pmatch o
((param-list . ,formals)
(let ((n (length formals)))
;;(stderr "FORMALS: ~a ==> ~a\n" formals n)
(map cons (map .name formals) (iota n -2 -1))))
(_ (format (current-error-port) "formals->symbols: no match: ~a\n" o)
barf)))
(define (string->symbols string)
(make-data string (append (string->list string) (list #\nul))))
(define (function->symbols symbols)
(lambda (o)
;;(stderr "\n")
(format (current-error-port) "compiling ~a\n" (.name o))
;;(stderr "formals=~a\n" (.formals o))
(let* ((text (formals->text (.formals o)))
(locals (formals->locals (.formals o)))
(text-offset (length (symbols->text symbols 0 0))))
;;(stderr "locals=~a\n" locals)
(let loop ((statements (.statements o))
(text+symbols+locals (make-text+symbols+locals text symbols locals)))
(if (null? statements) (append (.symbols text+symbols+locals) (list (make-function (.name o) (.text text+symbols+locals))))
(let* ((statement (car statements)))
(loop (cdr statements)
((statement->text+symbols+locals text+symbols+locals) (car statements)))))))))
(define _start
(let* ((argc-argv
(string-append ".byte"
" 0x89 0xe8" ; mov %ebp,%eax
" 0x83 0xc0 0x08" ; add $0x8,%eax
" 0x50" ; push %eax
" 0x89 0xe8" ; mov %ebp,%eax
" 0x83 0xc0 0x04" ; add $0x4,%eax
" 0x0f 0xb6 0x00" ; movzbl (%eax),%eax
" 0x50" ; push %eax
))
(ast (with-input-from-string
(string-append "int _start () {int i;asm(\"" argc-argv "\");i=main ();exit (i);}")
parse-c99))
(functions (filter ast:function? (cdr ast))))
;;(pretty-print ast (current-error-port))
(list (find (lambda (x) (equal? (.name x) "_start")) functions))))
(define strlen
(let* ((ast (with-input-from-string
"
int
strlen (char const* s)
{
int i = 0;
while (s[i]) i++;
return i;
}
"
parse-c99))
(functions (filter ast:function? (cdr ast))))
;;(pretty-print ast (current-error-port))
(list (find (lambda (x) (equal? (.name x) "strlen")) functions))))
(define eputs
(let* ((ast (with-input-from-string
"
int
eputs (char const* s)
{
//write (STDERR, s, strlen (s));
//write (2, s, strlen (s));
int i = strlen (s);
write (2, s, i);
return 0;
}
"
parse-c99))
(functions (filter ast:function? (cdr ast))))
;;(pretty-print ast (current-error-port))
(list (find (lambda (x) (equal? (.name x) "eputs")) functions))))
(define fputs
(let* ((ast (with-input-from-string
"
int
fputs (char const* s, int fd)
{
int i = strlen (s);
write (fd, s, i);
return 0;
}
"
parse-c99))
(functions (filter ast:function? (cdr ast))))
;;(pretty-print ast (current-error-port))
(list (find (lambda (x) (equal? (.name x) "fputs")) functions))))
(define puts
(let* ((ast (with-input-from-string
"
int
puts (char const* s)
{
//write (STDOUT, s, strlen (s));
//int i = write (STDOUT, s, strlen (s));
int i = strlen (s);
write (1, s, i);
return 0;
}
"
parse-c99))
(functions (filter ast:function? (cdr ast))))
;;(pretty-print ast (current-error-port))
(list (find (lambda (x) (equal? (.name x) "puts")) functions))))
(define i386:libc
(list
(make-function "exit" (list i386:exit))
(make-function "write" (list i386:write))))
(define libc
(append
strlen
eputs
fputs
puts))
(define (compile)
(let* ((ast (mescc))
(functions (filter ast:function? (cdr ast)))
(functions (append libc functions _start)))
(let loop ((functions functions) (symbols i386:libc))
(if (null? functions) (symbols->exe symbols)
(loop (cdr functions) ((function->symbols symbols) (car functions)))))))