artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

mescc: Support any expression as arg.

Browse source 
* module/language/c99/compiler.mes (expr->arg): Also push parameter,
  always return info.
  (ast->info): Loop over args.  Fixes using function calls in arguments.
* module/mes/libc-i386.mes (i386:push-arg): Remove.
  (i386:call, i386:call-accu): Remove arguments parameter.
* doc/examples/t.c: Test it.
This commit is contained in:
Jan Nieuwenhuizen 2017-02-27 07:50:33 +01:00
parent 394a3925be
commit c9b251616a
5 changed files with 204 additions and 159 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

229
module/language/c99/compiler.mes
View file

@ -176,18 +176,33 @@
(text text)) (text text))
(make <info> #:types types #:constants constants #:functions functions #:globals globals #:init init #:locals locals #:function function #:text text)))))) (make <info> #:types types #:constants constants #:functions functions #:globals globals #:init init #:locals locals #:function function #:text text))))))
(define (push-global-address globals)
(lambda (o)
(lambda (f g ta t d)
(i386:push-global-address (+ (data-offset o g) d)))))
(define (push-global globals) (define (push-global globals)
(lambda (o) (lambda (o)
(lambda (f g ta t d) (lambda (f g ta t d)
(i386:push-global (+ (data-offset o g) d))))) (i386:push-global (+ (data-offset o g) d)))))
(define (push-local locals)
(lambda (o)
(lambda (f g ta t d)
(i386:push-local (local:id o)))))
(define (push-global-address globals)
(lambda (o)
(lambda (f g ta t d)
(i386:push-global-address (+ (data-offset o g) d)))))
(define (push-local-address locals)
(lambda (o)
(lambda (f g ta t d)
(i386:push-local-address (local:id o)))))
(define push-global-de-ref push-global) (define push-global-de-ref push-global)
(define (push-local-de-ref locals)
(lambda (o)
(lambda (f g ta t d)
(i386:push-local-de-ref (local:id o)))))
(define (string->global string) (define (string->global string)
(make-global string "string" 0 (append (string->list string) (list #\nul)))) (make-global string "string" 0 (append (string->list string) (list #\nul))))
@ -203,97 +218,118 @@
(define (push-ident info) (define (push-ident info)
(lambda (o) (lambda (o)
(let ((local (assoc-ref (.locals info) o))) (let ((local (assoc-ref (.locals info) o)))
(if local (i386:push-local (local:id local)) (if local ((push-local (.locals info)) local)
((push-global (.globals info)) o))))) ;; FIXME: char*/int ((push-global (.globals info)) o))))) ;; FIXME: char*/int
(define (push-ident-address info) (define (push-ident-address info)
(lambda (o) (lambda (o)
(let ((local (assoc-ref (.locals info) o))) (let ((local (assoc-ref (.locals info) o)))
(if local (i386:push-local-address (local:id local)) (if local ((push-local-address (.locals info)) local)
((push-global-address (.globals info)) o))))) ((push-global-address (.globals info)) o)))))
(define (push-ident-de-ref info) (define (push-ident-de-ref info)
(lambda (o) (lambda (o)
(let ((local (assoc-ref (.locals info) o))) (let ((local (assoc-ref (.locals info) o)))
(if local (i386:push-local-de-ref (local:id local)) (if local ((push-local-de-ref (.locals info)) local)
((push-global-de-ref (.globals info)) o))))) ((push-global-de-ref (.globals info)) o)))))
(define (expr->arg info) ;; FIXME: get Mes curried-definitions (define (expr->arg info) ;; FIXME: get Mes curried-definitions
(lambda (o) (lambda (o)
(pmatch o (let ((text (.text info)))
((p-expr (fixed ,value)) (cstring->number value)) (pmatch o
((neg (p-expr (fixed ,value))) (- (cstring->number value))) ((p-expr (fixed ,value))
((p-expr (string ,string)) ((push-global-address info) string)) (let ((value (cstring->number value)))
((p-expr (ident ,name)) (clone info #:text (append text
((push-ident info) name)) (list
(lambda (f g ta t d)
(append
(i386:value->accu value)
(i386:push-accu))))))))
;; g_cells[0] ((neg (p-expr (fixed ,value)))
((array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))) (let ((value (- (cstring->number value))))
(let ((index (cstring->number index)) (clone info #:text (append text
(size 4)) ;; FIXME: type: int (list
(append (lambda (f g ta t d)
((ident->base info) array) (append
(list (i386:value->accu value)
(lambda (f g ta t d) (i386:push-accu))))))))
(append
(i386:value->accu (* size index)) ;; FIXME: type: int
(i386:base-mem->accu) ;; FIXME: type: int
(i386:push-accu) ;; hmm
))))))
;; g_cells[i] ((p-expr (string ,string))
((array-ref (p-expr (ident ,index)) (p-expr (ident ,array))) (clone info #:text (append text (list ((push-global-address info) string)))))
(let ((index (cstring->number index))
(size 4)) ;; FIXME: type: int
(append
((ident->base info) array)
((ident->accu info) array)
(list (lambda (f g ta t d)
;;(i386:byte-base-mem->accu)
(i386:base-mem->accu)
))
(list
(lambda (f g ta t d)
(append
(i386:push-accu)))))))
((de-ref (p-expr (ident ,name))) ((p-expr (ident ,name))
(lambda (f g ta t d) (clone info #:text (append text (list ((push-ident info) name)))))
((push-ident-de-ref info) name)))
((ref-to (p-expr (ident ,name))) ;; g_cells[0]
(lambda (f g ta t d) ((array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))
((push-ident-address info) name))) (let ((index (cstring->number index))
(size 4)) ;; FIXME: type: int
(clone info
#:text (append text
((ident->base info) array)
(list
(lambda (f g ta t d)
(append
(i386:value->accu (* size index)) ;; FIXME: type: int
(i386:base-mem->accu) ;; FIXME: type: int
(i386:push-accu))))))))
;; f (car (x)) ;; g_cells[i]
((fctn-call . ,call) ((array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))
(let* ((empty (clone info #:text '())) (let ((index (cstring->number index))
(info ((ast->info empty) o))) (size 4)) ;; FIXME: type: int
(append (.text info) (clone info #:text (append text
(list ((ident->base info) array)
(lambda (f g ta t d) ((ident->accu info) array)
(i386:push-accu)))))) (list
(lambda (f g ta t d)
(i386:base-mem->accu)))
(list
(lambda (f g ta t d)
(i386:push-accu)))))))
;; f (CAR (x)) ((de-ref (p-expr (ident ,name)))
((d-sel . ,d-sel) (clone info #:text (append text (list ((push-ident-de-ref info) name)))))
(let* ((empty (clone info #:text '()))
(expr ((expr->accu empty) `(d-sel ,@d-sel))))
(append (.text expr)
(list (lambda (f g ta t d)
(i386:push-accu))))))
;; f (0 + x) ((ref-to (p-expr (ident ,name)))
;;; aargh (clone info #:text (append text (list ((push-ident-address info) name)))))
;;;((add (p-expr (fixed ,value)) (d-sel (ident cdr) (array-ref (p-expr (ident x)) (p-expr (ident g_cells))))))
((cast (type-name (decl-spec-list (type-spec (fixed-type _))) ;; f (car (x))
(abs-declr (pointer))) ((fctn-call . ,call)
,cast) (let* (;;(empty (clone info #:text '()))
((expr->arg info) cast)) ;;(info ((ast->info empty) o))
(_ (info ((ast->info info) o))
(format (current-error-port) "SKIP: expr->arg=~s\n" o) (text (.text info)))
barf (clone info
0)))) #:text (append text
(list
(lambda (f g ta t d)
(i386:push-accu)))))))
;; f (CAR (x))
((d-sel . ,d-sel)
(let* (;;(empty (clone info #:text '()))
;;(expr ((expr->accu empty) `(d-sel ,@d-sel)))
(expr ((expr->accu info) `(d-sel ,@d-sel)))
(text (.text expr)))
(clone info
#:text (append text
(list (lambda (f g ta t d)
(i386:push-accu)))))))
;; f (0 + x)
;;; aargh
;;;((add (p-expr (fixed ,value)) (d-sel (ident cdr) (array-ref (p-expr (ident x)) (p-expr (ident g_cells))))))
((cast (type-name (decl-spec-list (type-spec (fixed-type _)))
(abs-declr (pointer)))
,cast)
((expr->arg info) cast))
(_
(format (current-error-port) "SKIP: expr->arg=~s\n" o)
barf
0)))))
;; FIXME: see ident->base ;; FIXME: see ident->base
(define (ident->accu info) (define (ident->accu info)
@ -1019,47 +1055,46 @@
(clone info #:text (append text (list (lambda (f g ta t d) (asm->hex arg0)))))) (clone info #:text (append text (list (lambda (f g ta t d) (asm->hex arg0))))))
(let* ((globals (append globals (filter-map expr->global expr-list))) (let* ((globals (append globals (filter-map expr->global expr-list)))
(info (clone info #:globals globals)) (info (clone info #:globals globals))
(args (map (expr->arg info) expr-list))) (text-length (length text))
(args-info (let loop ((expressions (reverse expr-list)) (info info))
(if (null? expressions) info
(loop (cdr expressions) ((expr->arg info) (car expressions))))))
(text (.text args-info))
(n (length expr-list)))
(if ;;#t ;;(assoc-ref globals name) (if ;;#t ;;(assoc-ref globals name)
(not (equal? name "functionx")) (not (equal? name "functionx"))
(clone info #:text (clone args-info #:text
(append text (append text
(list (lambda (f g ta t d) (list (lambda (f g ta t d)
(apply i386:call (cons* f g ta t d (i386:call f g ta t d (+ t (function-offset name f)) n))))
(+ t (function-offset name f)) args)))))
#:globals globals) #:globals globals)
(let* ((empty (clone info #:text '())) (let* ((empty (clone info #:text '()))
;;(accu ((ident->accu info) name))
(accu ((expr->accu empty) `(p-expr (ident ,name))))) (accu ((expr->accu empty) `(p-expr (ident ,name)))))
(stderr "DINGES: ~a\n" o) (stderr "DINGES: ~a\n" o)
(clone info #:text (clone args-info #:text
(append text (append text
(list (lambda (f g ta t d)
'(#x90)))
;;accu
(.text accu) (.text accu)
(list (lambda (f g ta t d) (list (lambda (f g ta t d)
'(#x90))) (i386:call-accu f g ta t d n))))
(list (lambda (f g ta t d)
(apply i386:call-accu (cons* f g ta t d args)))))
#:globals globals)))))) #:globals globals))))))
;;((expr-stmt (fctn-call (d-sel (ident "function") (array-ref (d-sel (ident "cdr") (array-ref (p-expr (ident "fn")) (p-expr (ident "g_cells")))) (p-expr (ident "g_functions")))) (expr-list)))) ;;((expr-stmt (fctn-call (d-sel (ident "function") (array-ref (d-sel (ident "cdr") (array-ref (p-expr (ident "fn")) (p-expr (ident "g_cells")))) (p-expr (ident "g_functions")))) (expr-list))))
((expr-stmt (fctn-call ,function (expr-list . ,expr-list))) ((expr-stmt (fctn-call ,function (expr-list . ,expr-list)))
(let* ((globals (append globals (filter-map expr->global expr-list))) (let* ((globals (append globals (filter-map expr->global expr-list)))
(info (clone info #:globals globals)) (info (clone info #:globals globals))
(args (map (expr->arg info) expr-list)) (text-length (length text))
(empty (clone info #:text '())) (args-info (let loop ((expressions (reverse expr-list)) (info info))
(accu ((expr->accu empty) function))) (if (null? expressions) info
(loop (cdr expressions) ((expr->arg info) (car expressions))))))
(text (.text args-info))
(n (length expr-list))
(empty (clone info #:text '()))
(accu ((expr->accu empty) function)))
(clone info #:text (clone info #:text
(append text (append text
(list (lambda (f g ta t d)
'(#x90)))
(.text accu) (.text accu)
(list (lambda (f g ta t d) (list (lambda (f g ta t d)
'(#x90))) (i386:call-accu f g ta t d n))))
(list (lambda (f g ta t d)
(apply i386:call-accu (cons* f g ta t d args)))))
#:globals globals))) #:globals globals)))
((if ,test ,body) ((if ,test ,body)
@ -1716,11 +1751,7 @@
(offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) ) (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) )
(clone info #:text (append text (clone info #:text (append text
(.text expr) (.text expr)
(list (lambda (f g ta t d)
'(#x90)))
(.text base) (.text base)
(list (lambda (f g ta t d)
'(#x90)))
(list (lambda (f g ta t d) (list (lambda (f g ta t d)
;;(i386:byte-base->accu-ref) ;; FIXME: size ;;(i386:byte-base->accu-ref) ;; FIXME: size
(i386:base->accu-address) (i386:base->accu-address)

48
module/mes/libc-i386.mes
View file

@ -68,17 +68,6 @@
(define (i386:push-base) (define (i386:push-base)
'(#x52)) ; push %eax '(#x52)) ; push %eax
(define (i386:push-arg f g ta t d)
(lambda (o)
(or o push-arg)
(cond ((number? o)
`(#x68 ,@(int->bv32 o))) ; push $<o>
((and (pair? o) (procedure? (car o)))
(append-map (lambda (p) (p f g ta t d)) o))
((pair? o) o)
((procedure? o) (o f g ta t d))
(_ barf))))
(define (i386:ret . rest) (define (i386:ret . rest)
(lambda (f g ta t d) (lambda (f g ta t d)
`( `(
@ -280,36 +269,17 @@
(or n local-test) (or n local-test)
`(#x83 #x7d ,(- 0 (* 4 n)) ,v)) ; cmpl $<v>,0x<n>(%ebp) `(#x83 #x7d ,(- 0 (* 4 n)) ,v)) ; cmpl $<v>,0x<n>(%ebp)
(define (i386:call f g ta t d address . arguments) (define (i386:call f g ta t d address n)
(or address urg:call) (or address urg:call)
(let* ((pushes (append-map (i386:push-arg f g ta t d) (reverse arguments))) `(#xe8 ,@(int->bv32 (- address 5)) ; call relative $00
(s (length pushes)) #x83 #xc4 ,(* n 4))) ; add $00,%esp
(n (length arguments)))
`( (define (i386:call-accu f g ta t d n)
,@pushes ; push args `(,@(i386:push-accu)
#xe8 ,@(int->bv32 (- address 5 s)) ; call relative ,@(i386:pop-accu)
#x83 #xc4 ,(* n 4) ; add $00,%esp #xff #xd0 ; call *%eax
))) #x83 #xc4 ,(* n 4))) ; add $00,%esp
(define (i386:call-accu f g ta t d . arguments)
;;(or address urg:call)
(let* ((pushes (append-map (i386:push-arg f g ta t d) (reverse arguments)))
(s (length pushes))
(n (length arguments)))
`(
,@(i386:push-accu)
,@pushes ; push args
;;#xe8 ,@(int->bv32 (- address 5 s)) ; call relative
;; FIXME: add t?/address
;; #x50 ; push %eax
;; #xc3 ; ret
,@(i386:pop-accu)
;; #x05 ,@(int->bv32 t) ; add <t>,%eax
;; #x05 ,@(int->bv32 ta) ; add <ta>,%eax
#xff #xd0 ; call *%eax
#x83 #xc4 ,(* n 4) ; add $00,%esp
)))
(define (i386:accu-not) (define (i386:accu-not)
`(#x0f #x94 #xc0 ; sete %al `(#x0f #x94 #xc0 ; sete %al
#x0f #xb6 #xc0)) ; movzbl %al,%eax #x0f #xb6 #xc0)) ; movzbl %al,%eax

5
module/mes/libc-i386.scm
View file

@ -117,13 +117,16 @@
i386:xor-accu i386:xor-accu
i386:xor-zf i386:xor-zf
;; long jump
i386:Xjump
i386:Xjump i386:Xjump
i386:XXjump
i386:Xjump-c i386:Xjump-c
i386:Xjump-nc i386:Xjump-nc
i386:Xjump-nz i386:Xjump-nz
i386:Xjump-z i386:Xjump-z
i386:XXjump
;; libc ;; libc
i386:exit i386:exit
i386:open i386:open

35
scaffold/mini-mes.c
View file

@ -609,10 +609,21 @@ push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
} }
#endif #endif
#if __GNUC__
SCM caar (SCM x) {return car (car (x));} SCM caar (SCM x) {return car (car (x));}
SCM cadr (SCM x) {return car (cdr (x));} SCM cadr (SCM x) {return car (cdr (x));}
SCM cdar (SCM x) {return cdr (car (x));} SCM cdar (SCM x) {return cdr (car (x));}
SCM cddr (SCM x) {return cdr (cdr (x));} SCM cddr (SCM x) {return cdr (cdr (x));}
#else
SCM cadr (SCM x) {
x = cdr (x);
return car (x);
}
SCM cddr (SCM x) {
x = cdr (x);
return cdr (x);
}
#endif
#if __GNUC__ #if __GNUC__
//FIXME //FIXME
@ -625,6 +636,10 @@ eval_apply ()
{ {
puts ("e/a: fixme\n"); puts ("e/a: fixme\n");
eval_apply: eval_apply:
asm (".byte 0x90");
asm (".byte 0x90");
asm (".byte 0x90");
asm (".byte 0x90");
puts ("eval_apply\n"); puts ("eval_apply\n");
// if (g_free + GC_SAFETY > ARENA_SIZE) // if (g_free + GC_SAFETY > ARENA_SIZE)
// gc_pop_frame (gc (gc_push_frame ())); // gc_pop_frame (gc (gc_push_frame ()));
@ -987,11 +1002,6 @@ eval_apply ()
gc_pop_frame (); gc_pop_frame ();
puts ("vm-return01\n"); puts ("vm-return01\n");
r1 = x; r1 = x;
//FIXME:
r3 = cell_unspecified;
/// fIXME: must via eval-apply
return r1;
goto eval_apply; goto eval_apply;
} }
@ -1069,9 +1079,24 @@ gc_peek_frame ()
{ {
SCM frame = car (g_stack); SCM frame = car (g_stack);
r1 = car (frame); r1 = car (frame);
#if __GNUC__
r2 = cadr (frame); r2 = cadr (frame);
r3 = car (cddr (frame)); r3 = car (cddr (frame));
r0 = cadr (cddr (frame)); r0 = cadr (cddr (frame));
#else
r2 = cdr (frame);
r2 = car (r2);
r3 = cdr (frame);
r3 = cdr (r3);
r3 = car (r3);
r0 = cdr (frame);
r0 = cdr (r0);
r0 = cdr (r0);
r0 = cdr (r0);
r0 = car (r0);
#endif
return frame; return frame;
} }

46
scaffold/t.c
View file

@ -124,6 +124,19 @@ SCM tmp;
SCM tmp_num; SCM tmp_num;
#if 1 #if 1
int
add (int a, int b)
{
return a + b;
}
int
inc (int i)
{
return i + 1;
}
int int
label (int c) label (int c)
{ {
@ -444,6 +457,24 @@ test (char *p)
*x++ = c; *x++ = c;
if (*g_chars != 'C') return 1; if (*g_chars != 'C') return 1;
puts ("t: inc (0)\n");
if (inc (0) != 1) return 1;
puts ("t: inc (inc (0))\n");
if (inc (inc (0)) != 2) return 1;
puts ("t: inc (inc (inc (0)))\n");
if (inc (inc (inc (0))) != 3) return 1;
puts ("t: add (1, 2)\n");
if (add (1, 2) != 3) return 1;
puts ("t: add (inc (0), inc (1))\n");
if (add (inc (0), inc (1)) != 3) return 1;
puts ("t: add (inc (inc (0)), inc (inc (1)))\n");
if (add (inc (inc (0)), inc (inc (1))) != 5) return 1;
puts ("t: goto label\n"); puts ("t: goto label\n");
if (label (1) != 0) return 1; if (label (1) != 0) return 1;
@ -576,21 +607,6 @@ test (char *p)
int int
main (int argc, char *argv[]) main (int argc, char *argv[])
{ {
// main:
// puts ("t.c\n");
// if (argc == 0x22) return 11;
// argc = 0x22;
// goto main;
// switch (0)
// {
// case 0: {goto next;}
// // case 1: {goto next;}
// // case 2: {goto next;}
// // default: {goto next;}
// }
// return 1;
// next:
char *p = "t.c\n"; char *p = "t.c\n";
puts ("t.c\n"); puts ("t.c\n");