andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

mescc: Prepare for x86_64 support. 

* module/mescc/info.scm (info): Add allocated, registers.
* module/mescc/i386/info.scm: New file.
* build-aux/build-guile.sh (SCM_FILES): Add it.
* module/mescc/compile.scm (c99-input->info): Add info parameter.
(c99-ast->info): Likewise.
(i386:type-alist): Remove.
(alloc-register, free-register): New function.
(expr->register*): Rename from expr->accu*.  Update callers.
(expr->accu): Rename from expr->accu.  Update callers.
* module/mescc/mescc.scm(%info): New variable.
* module/mescc/mescc.scm (c->ast): Use it.
(mescc:compile): Likewise.
(E->info): Likewise.
This commit is contained in:
Jan Nieuwenhuizen 2018-08-14 12:35:24 +02:00
parent 92aad1ceaf
commit ee9081f3ec
No known key found for this signature in database
GPG Key ID: F3C1A0D9C1D65273
6 changed files with 195 additions and 136 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
build-aux/build-guile.sh
View File

@ -38,6 +38,7 @@ ${srcdest}module/mescc/as.scm
${srcdest}module/mescc/bytevectors.scm ${srcdest}module/mescc/bytevectors.scm
${srcdest}module/mescc/compile.scm ${srcdest}module/mescc/compile.scm
${srcdest}module/mescc/i386/as.scm ${srcdest}module/mescc/i386/as.scm
${srcdest}module/mescc/i386/info.scm
${srcdest}module/mescc/info.scm ${srcdest}module/mescc/info.scm
${srcdest}module/mescc/mescc.scm ${srcdest}module/mescc/mescc.scm
${srcdest}module/mescc/preprocess.scm ${srcdest}module/mescc/preprocess.scm

221
module/mescc/compile.scm
View File

@ -43,13 +43,13 @@
(define mes? (pair? (current-module))) (define mes? (pair? (current-module)))
(define* (c99-input->info #:key (prefix "") (defines '()) (includes '())) (define* (c99-input->info info #:key (prefix "") (defines '()) (includes '()))
(let ((ast (c99-input->ast #:prefix prefix #:defines defines #:includes includes))) (let ((ast (c99-input->ast #:prefix prefix #:defines defines #:includes includes)))
(c99-ast->info ast))) (c99-ast->info info ast)))
(define* (c99-ast->info o) (define* (c99-ast->info info o)
(stderr "compiling: input\n") (stderr "compiling: input\n")
(let ((info (ast->info o (make <info> #:types i386:type-alist)))) (let ((info (ast->info o info)))
(clean-info info))) (clean-info info)))
(define (clean-info o) (define (clean-info o)
@ -74,41 +74,6 @@
(let ((size (apply max (map (compose ->size cdr) fields)))) (let ((size (apply max (map (compose ->size cdr) fields))))
(cons `(tag ,name) (make-type 'union size fields)))) (cons `(tag ,name) (make-type 'union size fields))))
(define i386:type-alist
`(("char" . ,(make-type 'signed 1 #f))
("short" . ,(make-type 'signed 2 #f))
("int" . ,(make-type 'signed 4 #f))
("long" . ,(make-type 'signed 4 #f))
("default" . ,(make-type 'signed 4 #f))
;;("long long" . ,(make-type 'signed 8 #f))
;;("long long int" . ,(make-type 'signed 8 #f))
("long long" . ,(make-type 'signed 4 #f)) ;; FIXME
("long long int" . ,(make-type 'signed 4 #f))
("void" . ,(make-type 'void 1 #f))
;; FIXME sign
("unsigned char" . ,(make-type 'unsigned 1 #f))
("unsigned short" . ,(make-type 'unsigned 2 #f))
("unsigned" . ,(make-type 'unsigned 4 #f))
("unsigned int" . ,(make-type 'unsigned 4 #f))
("unsigned long" . ,(make-type 'unsigned 4 #f))
;; ("unsigned long long" . ,(make-type 'builtin 8 #f))
;; ("unsigned long long int" . ,(make-type 'builtin 8 #f))
("unsigned long long" . ,(make-type 'unsigned 4 #f)) ;; FIXME
("unsigned long long int" . ,(make-type 'unsigned 4 #f))
("float" . ,(make-type 'float 4 #f))
("double" . ,(make-type 'float 8 #f))
("long double" . ,(make-type 'float 16 #f))
;;
("short int" . ,(make-type 'signed 2 #f))
("unsigned short int" . ,(make-type 'unsigned 2 #f))
("long int" . ,(make-type 'signed 4 #f))
("unsigned long int" . ,(make-type 'unsigned 4 #f))))
(define (signed? o) (define (signed? o)
(eq? ((compose type:type ->type) o) 'signed)) (eq? ((compose type:type ->type) o) 'signed))
@ -552,7 +517,7 @@
(let* ((globals ((globals:add-string (.globals info)) string)) (let* ((globals ((globals:add-string (.globals info)) string))
(info (clone info #:globals globals))) (info (clone info #:globals globals)))
(append-text info ((push-global-address info) `(#:string ,string))))) (append-text info ((push-global-address info) `(#:string ,string)))))
(_ (let ((info (expr->accu o info))) (_ (let ((info (expr->register o info)))
(append-text info (wrap-as (i386:push-accu)))))))) (append-text info (wrap-as (i386:push-accu))))))))
(define (globals:add-string globals) (define (globals:add-string globals)
@ -739,43 +704,55 @@
(define (accu->base-mem*n info n) (define (accu->base-mem*n info n)
(append-text info (accu->base-mem*n- info n))) (append-text info (accu->base-mem*n- info n)))
(define (expr->accu* o info) (define (alloc-register info)
(let ((registers (.registers info)))
(stderr " =>register: ~a\n" (car registers))
(clone info #:allocated (cons (car registers) (.allocated info)) #:registers (cdr registers))))
(define (free-register info)
(let ((allocated (.allocated info)))
(stderr " <=register: ~a\n" (car allocated))
(clone info #:allocated (cdr allocated) #:registers (cons (car allocated) (.registers info)))))
(define (expr->register* o info)
(pmatch o (pmatch o
((p-expr (ident ,name)) ((p-expr (ident ,name))
(append-text info ((ident-address->accu info) name))) (let ((info (alloc-register info)))
(append-text info ((ident-address->accu info) name))))
((de-ref ,expr) ((de-ref ,expr)
(expr->accu expr info)) (expr->register expr info))
((d-sel (ident ,field) ,struct) ((d-sel (ident ,field) ,struct)
(let* ((type (ast->basic-type struct info)) (let* ((type (ast->basic-type struct info))
(offset (field-offset info type field)) (offset (field-offset info type field))
(info (expr->accu* struct info))) (info (expr->register* struct info)))
(append-text info (wrap-as (i386:accu+value offset))))) (append-text info (wrap-as (i386:accu+value offset)))))
((i-sel (ident ,field) (fctn-call (p-expr (ident ,function)) . ,rest)) ((i-sel (ident ,field) (fctn-call (p-expr (ident ,function)) . ,rest))
(let* ((type (ast->basic-type `(fctn-call (p-expr (ident ,function)) ,@rest) info)) (let* ((type (ast->basic-type `(fctn-call (p-expr (ident ,function)) ,@rest) info))
(offset (field-offset info type field)) (offset (field-offset info type field))
(info (expr->accu `(fctn-call (p-expr (ident ,function)) ,@rest) info))) (info (expr->register `(fctn-call (p-expr (ident ,function)) ,@rest) info)))
(append-text info (wrap-as (i386:accu+value offset))))) (append-text info (wrap-as (i386:accu+value offset)))))
((i-sel (ident ,field) ,struct) ((i-sel (ident ,field) ,struct)
(let* ((type (ast->basic-type struct info)) (let* ((type (ast->basic-type struct info))
(offset (field-offset info type field)) (offset (field-offset info type field))
(info (expr->accu* struct info))) (info (expr->register* struct info)))
(append-text info (append (wrap-as (i386:mem->accu)) (append-text info (append (wrap-as (i386:mem->accu))
(wrap-as (i386:accu+value offset)))))) (wrap-as (i386:accu+value offset))))))
((array-ref ,index ,array) ((array-ref ,index ,array)
(let* ((info (expr->accu index info)) (let* ((info (expr->register index info))
(size (ast->size o info)) (size (ast->size o info))
(info (accu*n info size)) (info (accu*n info size))
(info (expr->base array info))) (info (expr->base array info)))
(append-text info (wrap-as (i386:accu+base))))) (append-text info (wrap-as (i386:accu+base)))))
((cast ,type ,expr) ((cast ,type ,expr)
(expr->accu `(ref-to ,expr) info)) (expr->register `(ref-to ,expr) info))
((add ,a ,b) ((add ,a ,b)
(let* ((rank (expr->rank info a)) (let* ((rank (expr->rank info a))
@ -787,11 +764,11 @@
((and struct? (= rank 2)) 4) ((and struct? (= rank 2)) 4)
(else 1)))) (else 1))))
(if (or (= size 1)) ((binop->accu* info) a b (i386:accu+base)) (if (or (= size 1)) ((binop->accu* info) a b (i386:accu+base))
(let* ((info (expr->accu b info)) (let* ((info (expr->register b info))
(info (append-text info (wrap-as (append (i386:value->base size) (info (append-text info (wrap-as (append (i386:value->base size)
(i386:accu*base) (i386:accu*base)
(i386:accu->base))))) (i386:accu->base)))))
(info (expr->accu* a info))) (info (expr->register* a info)))
(append-text info (wrap-as (i386:accu+base))))))) (append-text info (wrap-as (i386:accu+base)))))))
((sub ,a ,b) ((sub ,a ,b)
@ -809,11 +786,11 @@
(if (and (not (= rank-b 2)) (not (= rank-b 1))) info (if (and (not (= rank-b 2)) (not (= rank-b 1))) info
(append-text info (wrap-as (append (i386:value->base size) (append-text info (wrap-as (append (i386:value->base size)
(i386:accu/base)))))) (i386:accu/base))))))
(let* ((info (expr->accu* b info)) (let* ((info (expr->register* b info))
(info (append-text info (wrap-as (append (i386:value->base size) (info (append-text info (wrap-as (append (i386:value->base size)
(i386:accu*base) (i386:accu*base)
(i386:accu->base))))) (i386:accu->base)))))
(info (expr->accu* a info))) (info (expr->register* a info)))
(append-text info (wrap-as (i386:accu-base))))))) (append-text info (wrap-as (i386:accu-base)))))))
((pre-dec ,expr) ((pre-dec ,expr)
@ -822,7 +799,7 @@
((> rank 1) 4) ((> rank 1) 4)
(else 1))) (else 1)))
(info ((expr-add info) expr (- size))) (info ((expr-add info) expr (- size)))
(info (append (expr->accu* expr info)))) (info (append (expr->register* expr info))))
info)) info))
((pre-inc ,expr) ((pre-inc ,expr)
@ -831,11 +808,11 @@
((> rank 1) 4) ((> rank 1) 4)
(else 1))) (else 1)))
(info ((expr-add info) expr size)) (info ((expr-add info) expr size))
(info (append (expr->accu* expr info)))) (info (append (expr->register* expr info))))
info)) info))
((post-dec ,expr) ((post-dec ,expr)
(let* ((info (expr->accu* expr info)) (let* ((info (expr->register* expr info))
(info (append-text info (wrap-as (i386:push-accu)))) (info (append-text info (wrap-as (i386:push-accu))))
(post (clone info #:text '())) (post (clone info #:text '()))
(post (append-text post (ast->comment o))) (post (append-text post (ast->comment o)))
@ -851,7 +828,7 @@
(clone info #:post (.text post)))) (clone info #:post (.text post))))
((post-inc ,expr) ((post-inc ,expr)
(let* ((info (expr->accu* expr info)) (let* ((info (expr->register* expr info))
(info (append-text info (wrap-as (i386:push-accu)))) (info (append-text info (wrap-as (i386:push-accu))))
(post (clone info #:text '())) (post (clone info #:text '()))
(post (append-text post (ast->comment o))) (post (append-text post (ast->comment o)))
@ -866,18 +843,21 @@
(post (append-text post (wrap-as (i386:pop-accu))))) (post (append-text post (wrap-as (i386:pop-accu)))))
(clone info #:post (.text post)))) (clone info #:post (.text post))))
(_ (error "expr->accu*: not supported: " o)))) (_ (error "expr->register*: not supported: " o))))
(define (expr-add info) (define (expr-add info)
(lambda (o n) (lambda (o n)
(let* ((info (expr->accu* o info)) (let* ((info (expr->register* o info))
(info (append-text info (wrap-as (i386:accu-mem-add n))))) (info (append-text info (wrap-as (i386:accu-mem-add n)))))
info))) info)))
(define (expr->accu o info) (define (expr->register o info)
(stderr "expr->register o=~s\n" o)
(let ((locals (.locals info)) (let ((locals (.locals info))
(text (.text info)) (text (.text info))
(globals (.globals info))) (globals (.globals info)))
(define (helper) (define (helper)
(pmatch o (pmatch o
((expr) info) ((expr) info)
@ -885,8 +865,8 @@
((comma-expr) info) ((comma-expr) info)
((comma-expr ,a . ,rest) ((comma-expr ,a . ,rest)
(let ((info (expr->accu a info))) (let ((info (expr->register a info)))
(expr->accu `(comma-expr ,@rest) info))) (expr->register `(comma-expr ,@rest) info)))
((p-expr (string ,string)) ((p-expr (string ,string))
(let* ((globals ((globals:add-string globals) string)) (let* ((globals ((globals:add-string globals) string))
@ -900,7 +880,8 @@
(append-text info (list (i386:label->accu `(#:string ,string)))))) (append-text info (list (i386:label->accu `(#:string ,string))))))
((p-expr (fixed ,value)) ((p-expr (fixed ,value))
(let ((value (cstring->int value))) (let ((value (cstring->int value))
(info (alloc-register info)))
(append-text info (wrap-as (i386:value->accu value))))) (append-text info (wrap-as (i386:value->accu value)))))
((p-expr (float ,value)) ((p-expr (float ,value))
@ -921,10 +902,10 @@
(append-text info ((ident->accu info) name))) (append-text info ((ident->accu info) name)))
((initzer ,initzer) ((initzer ,initzer)
(expr->accu initzer info)) (expr->register initzer info))
(((initzer ,initzer)) (((initzer ,initzer))
(expr->accu initzer info)) (expr->register initzer info))
;; offsetoff ;; offsetoff
((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base))))) ((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base)))))
@ -939,10 +920,10 @@
;; &*foo ;; &*foo
((ref-to (de-ref ,expr)) ((ref-to (de-ref ,expr))
(expr->accu expr info)) (expr->register expr info))
((ref-to ,expr) ((ref-to ,expr)
(expr->accu* expr info)) (expr->register* expr info))
((sizeof-expr ,expr) ((sizeof-expr ,expr)
(append-text info (wrap-as (i386:value->accu (ast->size expr info))))) (append-text info (wrap-as (i386:value->accu (ast->size expr info)))))
@ -951,12 +932,12 @@
(append-text info (wrap-as (i386:value->accu (ast->size type info))))) (append-text info (wrap-as (i386:value->accu (ast->size type info)))))
((array-ref ,index ,array) ((array-ref ,index ,array)
(let* ((info (expr->accu* o info)) (let* ((info (expr->register* o info))
(type (ast->type o info))) (type (ast->type o info)))
(append-text info (mem->accu type)))) (append-text info (mem->accu type))))
((d-sel ,field ,struct) ((d-sel ,field ,struct)
(let* ((info (expr->accu* o info)) (let* ((info (expr->register* o info))
(info (append-text info (ast->comment o))) (info (append-text info (ast->comment o)))
(type (ast->type o info)) (type (ast->type o info))
(size (->size type)) (size (->size type))
@ -965,7 +946,7 @@
(append-text info (mem->accu type))))) (append-text info (mem->accu type)))))
((i-sel ,field ,struct) ((i-sel ,field ,struct)
(let* ((info (expr->accu* o info)) (let* ((info (expr->register* o info))
(info (append-text info (ast->comment o))) (info (append-text info (ast->comment o)))
(type (ast->type o info)) (type (ast->type o info))
(size (->size type)) (size (->size type))
@ -974,7 +955,7 @@
(append-text info (mem->accu type))))) (append-text info (mem->accu type)))))
((de-ref ,expr) ((de-ref ,expr)
(let* ((info (expr->accu expr info)) (let* ((info (expr->register expr info))
(type (ast->type o info))) (type (ast->type o info)))
(append-text info (mem->accu type)))) (append-text info (mem->accu type))))
@ -994,7 +975,7 @@
(stderr "warning: undeclared function: ~a\n" name)) (stderr "warning: undeclared function: ~a\n" name))
(append-text args-info (list (i386:call-label name n)))) (append-text args-info (list (i386:call-label name n))))
(let* ((empty (clone info #:text '())) (let* ((empty (clone info #:text '()))
(accu (expr->accu `(p-expr (ident ,name)) empty))) (accu (expr->register `(p-expr (ident ,name)) empty)))
(append-text args-info (append (.text accu) (append-text args-info (append (.text accu)
(list (i386:call-accu n))))))))) (list (i386:call-accu n)))))))))
@ -1005,7 +986,7 @@
(loop (cdr expressions) ((expr->arg info) (car expressions)))))) (loop (cdr expressions) ((expr->arg info) (car expressions))))))
(n (length expr-list)) (n (length expr-list))
(empty (clone info #:text '())) (empty (clone info #:text '()))
(accu (expr->accu function empty))) (accu (expr->register function empty)))
(append-text args-info (append (.text accu) (append-text args-info (append (.text accu)
(list (i386:call-accu n)))))) (list (i386:call-accu n))))))
@ -1013,7 +994,7 @@
(ast->info `(expr-stmt ,o) info)) (ast->info `(expr-stmt ,o) info))
((post-inc ,expr) ((post-inc ,expr)
(let* ((info (append (expr->accu expr info))) (let* ((info (append (expr->register expr info)))
(info (append-text info (wrap-as (i386:push-accu)))) (info (append-text info (wrap-as (i386:push-accu))))
(rank (expr->rank info expr)) (rank (expr->rank info expr))
(size (cond ((= rank 1) (ast-type->size info expr)) (size (cond ((= rank 1) (ast-type->size info expr))
@ -1024,7 +1005,7 @@
info)) info))
((post-dec ,expr) ((post-dec ,expr)
(let* ((info (append (expr->accu expr info))) (let* ((info (append (expr->register expr info)))
(info (append-text info (wrap-as (i386:push-accu)))) (info (append-text info (wrap-as (i386:push-accu))))
(rank (expr->rank info expr)) (rank (expr->rank info expr))
(size (cond ((= rank 1) (ast-type->size info expr)) (size (cond ((= rank 1) (ast-type->size info expr))
@ -1040,7 +1021,7 @@
((> rank 1) 4) ((> rank 1) 4)
(else 1))) (else 1)))
(info ((expr-add info) expr size)) (info ((expr-add info) expr size))
(info (append (expr->accu expr info)))) (info (append (expr->register expr info))))
info)) info))
((pre-dec ,expr) ((pre-dec ,expr)
@ -1049,7 +1030,7 @@
((> rank 1) 4) ((> rank 1) 4)
(else 1))) (else 1)))
(info ((expr-add info) expr (- size))) (info ((expr-add info) expr (- size)))
(info (append (expr->accu expr info)))) (info (append (expr->register expr info))))
info)) info))
@ -1062,7 +1043,7 @@
((> rank 1) 4) ((> rank 1) 4)
((and struct? (= rank 2)) 4) ((and struct? (= rank 2)) 4)
(else 1))) (else 1)))
(info (expr->accu a info)) (info (expr->register a info))
(value (cstring->int value)) (value (cstring->int value))
(value (* size value))) (value (* size value)))
(append-text info (wrap-as (i386:accu+value value))))) (append-text info (wrap-as (i386:accu+value value)))))
@ -1077,11 +1058,11 @@
((and struct? (= rank 2)) 4) ((and struct? (= rank 2)) 4)
(else 1)))) (else 1))))
(if (or (= size 1)) ((binop->accu info) a b (i386:accu+base)) (if (or (= size 1)) ((binop->accu info) a b (i386:accu+base))
(let* ((info (expr->accu b info)) (let* ((info (expr->register b info))
(info (append-text info (wrap-as (append (i386:value->base size) (info (append-text info (wrap-as (append (i386:value->base size)
(i386:accu*base) (i386:accu*base)
(i386:accu->base))))) (i386:accu->base)))))
(info (expr->accu a info))) (info (expr->register a info)))
(append-text info (wrap-as (i386:accu+base))))))) (append-text info (wrap-as (i386:accu+base)))))))
((sub ,a (p-expr (fixed ,value))) ((sub ,a (p-expr (fixed ,value)))
@ -1093,7 +1074,7 @@
((> rank 1) 4) ((> rank 1) 4)
((and struct? (= rank 2)) 4) ((and struct? (= rank 2)) 4)
(else 1))) (else 1)))
(info (expr->accu a info)) (info (expr->register a info))
(value (cstring->int value)) (value (cstring->int value))
(value (* size value))) (value (* size value)))
(append-text info (wrap-as (i386:accu+value (- value)))))) (append-text info (wrap-as (i386:accu+value (- value))))))
@ -1113,11 +1094,11 @@
(if (and (not (= rank-b 2)) (not (= rank-b 1))) info (if (and (not (= rank-b 2)) (not (= rank-b 1))) info
(append-text info (wrap-as (append (i386:value->base size) (append-text info (wrap-as (append (i386:value->base size)
(i386:accu/base)))))) (i386:accu/base))))))
(let* ((info (expr->accu b info)) (let* ((info (expr->register b info))
(info (append-text info (wrap-as (append (i386:value->base size) (info (append-text info (wrap-as (append (i386:value->base size)
(i386:accu*base) (i386:accu*base)
(i386:accu->base))))) (i386:accu->base)))))
(info (expr->accu a info))) (info (expr->register a info)))
(append-text info (wrap-as (i386:accu-base))))))) (append-text info (wrap-as (i386:accu-base)))))))
((bitwise-and ,a ,b) ((binop->accu info) a b (i386:accu-and-base))) ((bitwise-and ,a ,b) ((binop->accu info) a b (i386:accu-and-base)))
@ -1182,49 +1163,50 @@
((binop->accu info) a b (append (i386:sub-base) (test->accu) (i386:accu-test))))) ((binop->accu info) a b (append (i386:sub-base) (test->accu) (i386:accu-test)))))
((or ,a ,b) ((or ,a ,b)
(let* ((info (expr->accu a info)) (let* ((info (expr->register a info))
(here (number->string (length (.text info)))) (here (number->string (length (.text info))))
(skip-b-label (string-append "_" (.function info) "_" here "_or_skip_b")) (skip-b-label (string-append "_" (.function info) "_" here "_or_skip_b"))
(info (append-text info (wrap-as (i386:accu-test)))) (info (append-text info (wrap-as (i386:accu-test))))
(info (append-text info (wrap-as (i386:jump-nz skip-b-label)))) (info (append-text info (wrap-as (i386:jump-nz skip-b-label))))
(info (append-text info (wrap-as (i386:accu-test)))) (info (append-text info (wrap-as (i386:accu-test))))
(info (expr->accu b info)) (info (expr->register b info))
(info (append-text info (wrap-as (i386:accu-test)))) (info (append-text info (wrap-as (i386:accu-test))))
(info (append-text info (wrap-as `((#:label ,skip-b-label)))))) (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
info)) info))
((and ,a ,b) ((and ,a ,b)
(let* ((info (expr->accu a info)) (let* ((info (expr->register a info))
(here (number->string (length (.text info)))) (here (number->string (length (.text info))))
(skip-b-label (string-append "_" (.function info) "_" here "_and_skip_b")) (skip-b-label (string-append "_" (.function info) "_" here "_and_skip_b"))
(info (append-text info (wrap-as (i386:accu-test)))) (info (append-text info (wrap-as (i386:accu-test))))
(info (append-text info (wrap-as (i386:jump-z skip-b-label)))) (info (append-text info (wrap-as (i386:jump-z skip-b-label))))
(info (append-text info (wrap-as (i386:accu-test)))) (info (append-text info (wrap-as (i386:accu-test))))
(info (expr->accu b info)) (info (expr->register b info))
(info (append-text info (wrap-as (i386:accu-test)))) (info (append-text info (wrap-as (i386:accu-test))))
(info (append-text info (wrap-as `((#:label ,skip-b-label)))))) (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
info)) info))
((cast ,type ,expr) ((cast ,type ,expr)
(let ((info (expr->accu expr info)) (let ((info (expr->register expr info))
(type (ast->type o info))) (type (ast->type o info)))
(append-text info (convert-accu type)))) (append-text info (convert-accu type))))
((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b) ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b)
(let* ((info (expr->accu `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info)) (let* ((info (expr->register `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info))
(type (ident->type info name)) (type (ident->type info name))
(rank (ident->rank info name)) (rank (ident->rank info name))
(size (if (> rank 1) 4 1))) (size (if (> rank 1) 4 1)))
(append-text info ((ident-add info) name size)))) (append-text info ((ident-add info) name size))))
((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b) ((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b)
(let* ((info (expr->accu `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info)) (let* ((info (expr->register `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info))
(type (ident->type info name)) (type (ident->type info name))
(rank (ident->rank info name)) (rank (ident->rank info name))
(size (if (> rank 1) 4 1))) (size (if (> rank 1) 4 1)))
(append-text info ((ident-add info) name (- size))))) (append-text info ((ident-add info) name (- size)))))
((assn-expr ,a (op ,op) ,b) ((assn-expr ,a (op ,op) ,b)
(stderr "ASSN!\n")
(let* ((info (append-text info (ast->comment o))) (let* ((info (append-text info (ast->comment o)))
(type (ast->type a info)) (type (ast->type a info))
(rank (->rank type)) (rank (->rank type))
@ -1232,7 +1214,7 @@
(rank-b (->rank type-b)) (rank-b (->rank type-b))
(size (if (zero? rank) (->size type) 4)) (size (if (zero? rank) (->size type) 4))
(size-b (if (zero? rank-b) (->size type-b) 4)) (size-b (if (zero? rank-b) (->size type-b) 4))
(info (expr->accu b info)) (info (expr->register b info))
(info (if (equal? op "=") info (info (if (equal? op "=") info
(let* ((struct? (structured-type? type)) (let* ((struct? (structured-type? type))
(size (cond ((= rank 1) (ast-type->size info a)) (size (cond ((= rank 1) (ast-type->size info a))
@ -1243,7 +1225,7 @@
(let ((info (append-text info (wrap-as (i386:value->base size))))) (let ((info (append-text info (wrap-as (i386:value->base size)))))
(append-text info (wrap-as (i386:accu*base)))))) (append-text info (wrap-as (i386:accu*base))))))
(info (append-text info (wrap-as (i386:push-accu)))) (info (append-text info (wrap-as (i386:push-accu))))
(info (expr->accu a info)) (info (expr->register a info))
(info (append-text info (wrap-as (i386:pop-base)))) (info (append-text info (wrap-as (i386:pop-base))))
(info (append-text info (cond ((equal? op "+=") (wrap-as (i386:accu+base))) (info (append-text info (cond ((equal? op "+=") (wrap-as (i386:accu+base)))
((equal? op "-=") (wrap-as (i386:accu-base))) ((equal? op "-=") (wrap-as (i386:accu-base)))
@ -1270,12 +1252,15 @@
(or (= size-b 1) (= size-b 2))))) (or (= size-b 1) (= size-b 2)))))
(stderr "ERROR assign: ~a" (with-output-to-string (lambda () (pretty-print-c99 o)))) (stderr "ERROR assign: ~a" (with-output-to-string (lambda () (pretty-print-c99 o))))
(stderr " size[~a]:~a != size[~a]:~a\n" rank size rank-b size-b)) (stderr " size[~a]:~a != size[~a]:~a\n" rank size rank-b size-b))
(stderr " assign a=~s\n" a)
(pmatch a (pmatch a
((p-expr (ident ,name)) ((p-expr (ident ,name))
(if (or (<= size 4) ;; FIXME: long long = int (if (or (<= size 4) ;; FIXME: long long = int
(<= size-b 4)) (append-text info ((accu->ident info) name)) (<= size-b 4)) (append-text info ((accu->ident info) name))
(let ((info (expr->base* a info))) (let* ((info (expr->base* a info))
(accu->base-mem*n info size)))) (info (accu->base-mem*n info size)))
;;???
(free-register info))))
(_ (let* ((info (expr->base* a info)) (_ (let* ((info (expr->base* a info))
(info (if (not (bit-field? type)) info (info (if (not (bit-field? type)) info
(let* ((bit (bit-field:bit type)) (let* ((bit (bit-field:bit type))
@ -1299,7 +1284,7 @@
info)))) info))))
(accu->base-mem*n info (min size (max 4 size-b)))))))) ;; FIXME: long long = int (accu->base-mem*n info (min size (max 4 size-b)))))))) ;; FIXME: long long = int
(_ (error "expr->accu: not supported: " o)))) (_ (error "expr->register: not supported: " o))))
(let ((info (helper))) (let ((info (helper)))
(if (null? (.post info)) info (if (null? (.post info)) info
@ -1329,19 +1314,19 @@
(define (expr->base o info) (define (expr->base o info)
(let* ((info (append-text info (wrap-as (i386:push-accu)))) (let* ((info (append-text info (wrap-as (i386:push-accu))))
(info (expr->accu o info)) (info (expr->register o info))
(info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu)))))) (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu))))))
info)) info))
(define (binop->accu info) (define (binop->accu info)
(lambda (a b c) (lambda (a b c)
(let* ((info (expr->accu a info)) (let* ((info (expr->register a info))
(info (expr->base b info))) (info (expr->base b info)))
(append-text info (wrap-as c))))) (append-text info (wrap-as c)))))
(define (binop->accu* info) (define (binop->accu* info)
(lambda (a b c) (lambda (a b c)
(let* ((info (expr->accu* a info)) (let* ((info (expr->register* a info))
(info (expr->base b info))) (info (expr->base b info)))
(append-text info (wrap-as c))))) (append-text info (wrap-as c)))))
@ -1350,7 +1335,7 @@
(define (expr->base* o info) (define (expr->base* o info)
(let* ((info (append-text info (wrap-as (i386:push-accu)))) (let* ((info (append-text info (wrap-as (i386:push-accu))))
(info (expr->accu* o info)) (info (expr->register* o info))
(info (append-text info (wrap-as (i386:accu->base)))) (info (append-text info (wrap-as (i386:accu->base))))
(info (append-text info (wrap-as (i386:pop-accu))))) (info (append-text info (wrap-as (i386:pop-accu)))))
info)) info))
@ -1538,6 +1523,7 @@
(_ (error "ptr-declr->rank not supported: " o)))) (_ (error "ptr-declr->rank not supported: " o))))
(define (ast->info o info) (define (ast->info o info)
(stderr "ast->info o=~s\n" o)
(let ((functions (.functions info)) (let ((functions (.functions info))
(globals (.globals info)) (globals (.globals info))
(locals (.locals info)) (locals (.locals info))
@ -1576,7 +1562,7 @@
(if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
(append-text info (wrap-as (asm->m1 arg0)))) (append-text info (wrap-as (asm->m1 arg0))))
(let* ((info (append-text info (ast->comment o))) (let* ((info (append-text info (ast->comment o)))
(info (expr->accu `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)) info))) (info (expr->register `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)) info)))
(append-text info (wrap-as (i386:accu-zero?)))))) (append-text info (wrap-as (i386:accu-zero?))))))
((if ,test ,then) ((if ,test ,then)
@ -1640,7 +1626,7 @@
(here (number->string (length text))) (here (number->string (length text)))
(label (string-append "_" (.function info) "_" here "_")) (label (string-append "_" (.function info) "_" here "_"))
(break-label (string-append label "break")) (break-label (string-append label "break"))
(info (expr->accu expr info)) (info (expr->register expr info))
(info (clone info #:break (cons break-label (.break info)))) (info (clone info #:break (cons break-label (.break info))))
(count (length (filter clause? statements))) (count (length (filter clause? statements)))
(default? (find (cut eq? <> 'default) (map clause? statements))) (default? (find (cut eq? <> 'default) (map clause? statements)))
@ -1673,7 +1659,7 @@
(info (append-text info (wrap-as `((#:label ,loop-label))))) (info (append-text info (wrap-as `((#:label ,loop-label)))))
(info (ast->info body info)) (info (ast->info body info))
(info (append-text info (wrap-as `((#:label ,continue-label))))) (info (append-text info (wrap-as `((#:label ,continue-label)))))
(info (expr->accu step info)) (info (expr->register step info))
(info (append-text info (wrap-as `((#:label ,initial-skip-label))))) (info (append-text info (wrap-as `((#:label ,initial-skip-label)))))
(info ((test-jump-label->info info break-label) test)) (info ((test-jump-label->info info break-label) test))
(info (append-text info (wrap-as (i386:jump loop-label)))) (info (append-text info (wrap-as (i386:jump loop-label))))
@ -1732,7 +1718,7 @@
(append-text info (wrap-as (i386:jump (string-append "_" (.function info) "_label_" label))))) (append-text info (wrap-as (i386:jump (string-append "_" (.function info) "_label_" label)))))
((return ,expr) ((return ,expr)
(let ((info (expr->accu expr info))) (let ((info (expr->register expr info)))
(append-text info (append (wrap-as (i386:ret)))))) (append-text info (append (wrap-as (i386:ret))))))
((decl . ,decl) ((decl . ,decl)
@ -1742,23 +1728,24 @@
) )
(decl->info info decl))) (decl->info info decl)))
;; ... ;; ...
((gt . _) (expr->accu o info)) ((gt . _) (expr->register o info))
((ge . _) (expr->accu o info)) ((ge . _) (expr->register o info))
((ne . _) (expr->accu o info)) ((ne . _) (expr->register o info))
((eq . _) (expr->accu o info)) ((eq . _) (expr->register o info))
((le . _) (expr->accu o info)) ((le . _) (expr->register o info))
((lt . _) (expr->accu o info)) ((lt . _) (expr->register o info))
((lshift . _) (expr->accu o info)) ((lshift . _) (expr->register o info))
((rshift . _) (expr->accu o info)) ((rshift . _) (expr->register o info))
;; EXPR ;; EXPR
((expr-stmt ,expression) ((expr-stmt ,expression)
(let ((info (expr->accu expression info))) (let* ((info (expr->register expression info))
(append-text info (wrap-as (i386:accu-zero?))))) (info (append-text info (wrap-as (i386:accu-zero?)))))
(free-register info)))
;; FIXME: why do we get (post-inc ...) here ;; FIXME: why do we get (post-inc ...) here
;; (array-ref ;; (array-ref
(_ (let ((info (expr->accu o info))) (_ (let ((info (expr->register o info)))
(append-text info (wrap-as (i386:accu-zero?)))))))) (append-text info (wrap-as (i386:accu-zero?))))))))
(define (ast-list->info o info) (define (ast-list->info o info)
@ -1912,13 +1899,13 @@
(define (init->accu o info) (define (init->accu o info)
(pmatch o (pmatch o
((initzer-list (initzer ,expr)) (expr->accu expr info)) ((initzer-list (initzer ,expr)) (expr->register expr info))
(((#:string ,string)) (((#:string ,string))
(append-text info (list (i386:label->accu `(#:string ,string))))) (append-text info (list (i386:label->accu `(#:string ,string)))))
((,number . _) (guard (number? number)) ((,number . _) (guard (number? number))
(append-text info (wrap-as (i386:value->accu 0)))) (append-text info (wrap-as (i386:value->accu 0))))
((,c . ,_) (guard (char? c)) info) ((,c . ,_) (guard (char? c)) info)
(_ (expr->accu o info)))) (_ (expr->register o info))))
(define (init-struct-field local field init info) (define (init-struct-field local field init info)
(let* ((offset (field-offset info (local:type local) (car field))) (let* ((offset (field-offset info (local:type local) (car field)))
@ -1930,7 +1917,7 @@
(local->accu local) (local->accu local)
(wrap-as (append (i386:accu->base))) (wrap-as (append (i386:accu->base)))
(wrap-as (append (i386:push-base))) (wrap-as (append (i386:push-base)))
(.text (expr->accu init empty)) (.text (expr->register init empty))
(wrap-as (append (i386:pop-base))) (wrap-as (append (i386:pop-base)))
(wrap-as (case size (wrap-as (case size
((1) (i386:byte-accu->base-mem+n offset)) ((1) (i386:byte-accu->base-mem+n offset))
@ -1951,7 +1938,7 @@
(local->accu local) (local->accu local)
(wrap-as (append (i386:accu->base))) (wrap-as (append (i386:accu->base)))
(wrap-as (append (i386:push-base))) (wrap-as (append (i386:push-base)))
(.text (expr->accu init empty)) (.text (expr->register init empty))
(wrap-as (append (i386:pop-base))) (wrap-as (append (i386:pop-base)))
(wrap-as (case size (wrap-as (case size
((1) (i386:byte-accu->base-mem+n offset)) ((1) (i386:byte-accu->base-mem+n offset))

67
module/mescc/i386/info.scm Normal file
View File

@ -0,0 +1,67 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU 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.
;;;
;;; GNU 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 GNU Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Initialize MesCC as i386/x86 compiler
;;; Code:
(define-module (mescc i386 info)
#:use-module (mescc info)
#:export (x86-info))
(define (x86-info)
(make <info> #:types i386:type-alist #:registers i386:registers))
;; FIXME: use abstract, unlimited R0...RN and make concrete in second pass?
(define i386:registers '("eax" "ebx" "ecx" "edx" "esi"))
(define i386:type-alist
`(("char" . ,(make-type 'signed 1 #f))
("short" . ,(make-type 'signed 2 #f))
("int" . ,(make-type 'signed 4 #f))
("long" . ,(make-type 'signed 4 #f))
("default" . ,(make-type 'signed 4 #f))
;;("long long" . ,(make-type 'signed 8 #f))
;;("long long int" . ,(make-type 'signed 8 #f))
("long long" . ,(make-type 'signed 4 #f)) ;; FIXME
("long long int" . ,(make-type 'signed 4 #f))
("void" . ,(make-type 'void 1 #f))
;; FIXME sign
("unsigned char" . ,(make-type 'unsigned 1 #f))
("unsigned short" . ,(make-type 'unsigned 2 #f))
("unsigned" . ,(make-type 'unsigned 4 #f))
("unsigned int" . ,(make-type 'unsigned 4 #f))
("unsigned long" . ,(make-type 'unsigned 4 #f))
;; ("unsigned long long" . ,(make-type 'builtin 8 #f))
;; ("unsigned long long int" . ,(make-type 'builtin 8 #f))
("unsigned long long" . ,(make-type 'unsigned 4 #f)) ;; FIXME
("unsigned long long int" . ,(make-type 'unsigned 4 #f))
("float" . ,(make-type 'float 4 #f))
("double" . ,(make-type 'float 8 #f))
("long double" . ,(make-type 'float 16 #f))
;;
("short int" . ,(make-type 'signed 2 #f))
("unsigned short int" . ,(make-type 'unsigned 2 #f))
("long int" . ,(make-type 'signed 4 #f))
("unsigned long int" . ,(make-type 'unsigned 4 #f))))

22
module/mescc/info.scm
View File

@ -44,6 +44,8 @@
.post .post
.break .break
.continue .continue
.allocated
.registers
<type> <type>
make-type make-type
@ -115,7 +117,7 @@
structured-type?)) structured-type?))
(define-immutable-record-type <info> (define-immutable-record-type <info>
(make-<info> types constants functions globals locals statics function text post break continue) (make-<info> types constants functions globals locals statics function text post break continue allocated registers)
info? info?
(types .types) (types .types)
(constants .constants) (constants .constants)
@ -127,11 +129,13 @@
(text .text) (text .text)
(post .post) (post .post)
(break .break) (break .break)
(continue .continue)) (continue .continue)
(registers .registers)
(allocated .allocated))
(define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (locals '()) (statics '()) (function #f) (text '()) (post '()) (break '()) (continue '())) (define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (locals '()) (statics '()) (function #f) (text '()) (post '()) (break '()) (continue '()) (allocated '()) (registers '()))
(cond ((eq? o <info>) (cond ((eq? o <info>)
(make-<info> types constants functions globals locals statics function text post break continue)))) (make-<info> types constants functions globals locals statics function text post break continue allocated registers))))
(define (clone o . rest) (define (clone o . rest)
(cond ((info? o) (cond ((info? o)
@ -145,7 +149,9 @@
(text (.text o)) (text (.text o))
(post (.post o)) (post (.post o))
(break (.break o)) (break (.break o))
(continue (.continue o))) (continue (.continue o))
(allocated (.allocated o))
(registers (.registers o)))
(let-keywords rest (let-keywords rest
#f #f
((types types) ((types types)
@ -158,8 +164,10 @@
(text text) (text text)
(post post) (post post)
(break break) (break break)
(continue continue)) (continue continue)
(make <info> #:types types #:constants constants #:functions functions #:globals globals #:locals locals #:statics statics #:function function #:text text #:post post #:break break #:continue continue)))))) (allocated allocated)
(registers registers))
(make <info> #:types types #:constants constants #:functions functions #:globals globals #:locals locals #:statics statics #:function function #:text text #:post post #:break break #:continue continue #:allocated allocated #:registers registers))))))
;; ("int" . ,(make-type 'builtin 4 #f 0 #f)) ;; ("int" . ,(make-type 'builtin 4 #f 0 #f))
;; (make-type 'enum 4 0 fields) ;; (make-type 'enum 4 0 fields)

7
module/mescc/mescc.scm
View File

@ -24,6 +24,7 @@
#:use-module (mes guile) #:use-module (mes guile)
#:use-module (mes misc) #:use-module (mes misc)
#:use-module (mescc i386 info)
#:use-module (mescc preprocess) #:use-module (mescc preprocess)
#:use-module (mescc compile) #:use-module (mescc compile)
#:use-module (mescc M1) #:use-module (mescc M1)
@ -32,6 +33,8 @@
mescc:assemble mescc:assemble
mescc:link)) mescc:link))
(define %info (x86-info))
(define GUILE-with-output-to-file with-output-to-file) (define GUILE-with-output-to-file with-output-to-file)
(define (with-output-to-file file-name thunk) (define (with-output-to-file file-name thunk)
(if (equal? file-name "-") (thunk) (if (equal? file-name "-") (thunk)
@ -82,11 +85,11 @@
(includes (cons dir includes)) (includes (cons dir includes))
(prefix (option-ref options 'prefix ""))) (prefix (option-ref options 'prefix "")))
(with-input-from-file file-name (with-input-from-file file-name
(cut c99-input->info #:prefix prefix #:defines defines #:includes includes)))) (cut c99-input->info %info #:prefix prefix #:defines defines #:includes includes))))
(define (E->info options file-name) (define (E->info options file-name)
(let ((ast (with-input-from-file file-name read))) (let ((ast (with-input-from-file file-name read)))
(c99-ast->info ast))) (c99-ast->info %info ast)))
(define (mescc:assemble options) (define (mescc:assemble options)
(let* ((files (option-ref options '() '("a.c"))) (let* ((files (option-ref options '() '("a.c")))

13
scaffold/main.c
View File

@ -18,18 +18,11 @@
* along with GNU Mes. If not, see <http://www.gnu.org/licenses/>. * along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
*/ */
int //V=2 CC64=gcc build-aux/cc64-mes.sh scaffold/main
test ()
{
return 2;
}
int int
main (int argc, char *argv[]) main (int argc, char *argv[])
{ {
if (argc == 6) return 42; argc = 42;
int a = 39; return argc;
if (argc > 1) a+=argc;
else a++;
return a + test ();
} }