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

mescc: Remove jump calculation, use labels: prepare.

Browse source 
* module/language/c99/compiler.mes (test-jump-label->info): New
  function.
* module/mes/as-i386.mes (i386:jump-label-z,i386:jump-label-byte-z,
  i386:jump-label-g, i386:jump-label-ge,i386:jump-label-nz): New
  functions.
* module/mes/as-i386.scm: Export them.
This commit is contained in:
Jan Nieuwenhuizen 2017-06-12 21:00:50 +02:00
parent 7cce8c6090
commit 5bf3c92938
7 changed files with 185 additions and 81 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -1153,6 +1153,60 @@
(_ ((jump i386:Xjump-z (wrap-as (i386:accu-zero?))) o))))) (_ ((jump i386:Xjump-z (wrap-as (i386:accu-zero?))) o)))))
(define (test-jump-label->info info label)
(define (jump type . test)
(lambda (o)
(let* ((info ((ast->info info) o))
(info (append-text info (wrap-as `(#:comment "jmp test LABEL"))))
(jump-text (wrap-as (type `(#:local ,label)))))
(append-text info (append (if (null? test) '() (car test))
jump-text)))))
(lambda (o)
(pmatch o
;; unsigned
;; ((le ,a ,b) ((jump i386:jump-label-ncz) o)) ; ja
;; ((lt ,a ,b) ((jump i386:jump-label-nc) o)) ; jae
;; ((ge ,a ,b) ((jump i386:jump-label-ncz) o))
;; ((gt ,a ,b) ((jump i386:jump-label-nc) o))
((le ,a ,b) ((jump i386:jump-label-g) o))
((lt ,a ,b) ((jump i386:jump-label-ge) o))
((ge ,a ,b) ((jump i386:jump-label-g) o))
((gt ,a ,b) ((jump i386:jump-label-ge) o))
((ne ,a ,b) ((jump i386:jump-label-nz) o))
((eq ,a ,b) ((jump i386:jump-label-nz) o))
((not _) ((jump i386:jump-label-z) o))
((and ,a ,b)
(let* ((info ((test-jump-label->info info label) a))
(info ((test-jump-label->info info label) b)))
info))
((or ,a ,b)
(let* ((here (number->string (length (.text info))))
(skip-b-label (string-append label "_skip_b_" here))
(b-label (string-append label "_b_" here))
(info ((test-jump-label->info info b-label) a))
(info (append-text info (wrap-as (i386:jump-label `(#:local ,skip-b-label)))))
(info (append-text info (wrap-as `(#:label ,b-label))))
(info ((test-jump-label->info info label) b))
(info (append-text info (wrap-as `(#:label ,skip-b-label)))))
info))
((array-ref . _) ((jump i386:jump-label-byte-z
(wrap-as (i386:accu-zero?))) o))
((de-ref _) ((jump i386:jump-label-byte-z
(wrap-as (i386:accu-zero?))) o))
((assn-expr (p-expr (ident ,name)) ,op ,expr)
((jump i386:jump-label-z
(append ((ident->accu info) name)
(wrap-as (i386:accu-zero?)))) o))
(_ ((jump i386:jump-label-z (wrap-as (i386:accu-zero?))) o)))))
(define (cstring->number s) (define (cstring->number s)
(cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16)) (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
((string-prefix? "0b" s) (string->number (string-drop s 2) 2)) ((string-prefix? "0b" s) (string->number (string-drop s 2) 2))

21
module/mes/as-i386.mes
View file

@ -349,6 +349,27 @@
(define (i386:jump-label label) (define (i386:jump-label label)
`(#xe9 ,label #f #f #f)) ; jmp . + <n> `(#xe9 ,label #f #f #f)) ; jmp . + <n>
(define (i386:jump-label-z label)
`(#x0f #x84 ,label #f #f #f)) ; jz . + <n>
(define (i386:jump-label-byte-z label)
`(#x84 #xc0 ; test %al,%al
#x74 ,label)) ; jne <n>
;; signed
(define (i386:jump-label-g label)
`(#x0f #x8f ,label #f #f #f)) ; jg/jnle <n>
;; signed
(define (i386:jump-label-ge label)
`(#x0f #x8d ,label #f #f #f)) ; jge/jnl <n>
(define (i386:jump-label-nz label)
`(#x0f #x85 ,label #f #f #f)) ; jnz . + <n>
(define (i386:jump-label-z label)
`(#x0f #x84 ,label #f #f #f)) ; jz . + <n>
(define (i386:Xjump-nz n) (define (i386:Xjump-nz n)
(or n (error "invalid value: i386:Xjump-nz: n: " n)) (or n (error "invalid value: i386:Xjump-nz: n: " n))
`(#x0f #x85 ,@(int->bv32 n))) ; jnz . + <n> `(#x0f #x85 ,@(int->bv32 n))) ; jnz . + <n>

7
module/mes/as-i386.scm
View file

@ -79,8 +79,15 @@
i386:label->base i386:label->base
i386:label-mem->accu i386:label-mem->accu
i386:label-mem->base i386:label-mem->base
i386:jump i386:jump
i386:jump-label i386:jump-label
i386:jump-label-byte-z
i386:jump-label-g
i386:jump-label-ge
i386:jump-label-nz
i386:jump-label-z
i386:jump-byte-nz i386:jump-byte-nz
i386:jump-byte-z i386:jump-byte-z
i386:jump-c i386:jump-c

16
module/mes/elf-util.mes
View file

@ -84,13 +84,15 @@
(if (null? text) '() (if (null? text) '()
(let ((label (car text))) (let ((label (car text)))
(if (number? label) (cons label (loop (cdr text) (1+ off))) (if (number? label) (cons label (loop (cdr text) (1+ off)))
(if (and (pair? label) (member (car label) '(#:comment #:label))) (if (and (pair? label) (member (car label) '(#:comment #:label))) (loop (cdr text) off)
(loop (cdr text) off) (let* ((prefix (cond ((and (pair? (cdr text))
(let* ((prefix (if (and (pair? (cdr text))
(pair? (cddr text)) (pair? (cddr text))
(boolean? (caddr text))) 4 (boolean? (caddr text))) 4)
2)) ((and (pair? (cdr text))
;;(foo (format (current-error-port) "LABEL=~s\n" label)) (boolean? (cadr text))) 2)
(else 1)))
;; (foo (format (current-error-port) "LABEL=~s\n" label))
;; (foo (format (current-error-port) " prefix=~s\n" prefix))
(address? (and (pair? label) (eq? (car label) #:address))) (address? (and (pair? label) (eq? (car label) #:address)))
(local? (and (pair? label) (eq? (car label) #:local))) (local? (and (pair? label) (eq? (car label) #:local)))
(relative? (and (pair? label) (eq? (car label) #:relative))) (relative? (and (pair? label) (eq? (car label) #:relative)))
@ -109,7 +111,7 @@
(and=> function-address (lambda (a) (+ a ta))) (and=> function-address (lambda (a) (+ a ta)))
(and=> function-address (lambda (a) (- a off prefix)))) (and=> function-address (lambda (a) (- a off prefix))))
(error "unresolved label: " label)))) (error "unresolved label: " label))))
(append ((if (= prefix 2) int->bv16 int->bv32) address) (append ((case prefix ((1) list) ((2) int->bv16) ((4) int->bv32)) address)
(loop (list-tail text prefix) (+ off prefix)))))))))))) (loop (list-tail text prefix) (+ off prefix))))))))))))
(define (function-prefix name functions) (define (function-prefix name functions)

54
module/mes/hex2.mes
View file

@ -123,24 +123,28 @@
16))) 16)))
((char? o) (dec->hex (char->integer o))) ((char? o) (dec->hex (char->integer o)))
((and (pair? o) (eq? (car o) #:string)) ((and (pair? o) (eq? (car o) #:string))
(format #f "&~a" (string->label (cadr o)))) (format #f "&~a" (string->label o)))
((string? o) (format #f "~a" o)) ((string? o) (format #f "~a" o))
(else (format #f "~a" o)))) (else (format #f "~a" o))))
(define (write-line o) (define (write-line function)
(lambda (o)
(newline) (newline)
(cond ((not (pair? o)) (cond ((not (pair? o))
(display (dec->hex o))) (display (dec->hex o)))
((number? (car o)) ((number? (car o))
;;(display (string-join (map dec->hex (filter identity o)) " ")) ;;(display (string-join (map dec->hex (filter identity o)) " "))
;; FIXME: c&p from elf-util: function->text
(let ((text (let loop ((text o)) (let ((text (let loop ((text o))
(if (null? text) '() (if (null? text) '()
(let ((label (car text))) (let ((label (car text)))
(if (number? label) (cons label (loop (cdr text))) (if (number? label) (cons label (loop (cdr text)))
(if (and (pair? label) (member (car label) '(#:comment #:label))) (loop (cdr text)) (if (and (pair? label) (member (car label) '(#:comment #:label))) (loop (cdr text))
(let* ((prefix (if (and (pair? (cdr text)) (let* ((prefix (cond ((and (pair? (cdr text))
(pair? (cddr text)) (pair? (cddr text))
(boolean? (caddr text))) 4 (boolean? (caddr text))) 4)
2)) ((and (pair? (cdr text))
(boolean? (cadr text))) 2)
(else 1)))
(address? (and (pair? label) (eq? (car label) #:address))) (address? (and (pair? label) (eq? (car label) #:address)))
(local? (and (pair? label) (eq? (car label) #:local))) (local? (and (pair? label) (eq? (car label) #:local)))
(relative? (and (pair? label) (eq? (car label) #:relative))) (relative? (and (pair? label) (eq? (car label) #:relative)))
@ -148,37 +152,51 @@
(function? (member label function-names)) (function? (member label function-names))
(string-label (string->label label)) (string-label (string->label label))
(string? (not (equal? string-label "string_#f"))) (string? (not (equal? string-label "string_#f")))
(global? (member label global-names))) (global? (member label global-names))
(label (if local? (string-append "local_" function "_" label) label)))
(cons (cond (cons (cond
((eq? prefix 1) (format #f "!~a" label)) ((eq? prefix 1) (format #f "!~a" label))
((eq? prefix 2) (format #f "@~a" label)) ((eq? prefix 2) (format #f "@~a" label))
(local? (format #f "%local_~a" label)) (local? (format #f "%~a" label))
(function? (format #f "%~a" label)) (function? (if address? (format #f "&~a" label)
(format #f "%~a" label)))
(string? (format #f "&~a" string-label)) (string? (format #f "&~a" string-label))
(global? (format #f "&~a" label)) (global? (format #f "&~a" label))
(else (format #f "%~a" label))) (else (format #f "%~a" label)))
(loop (list-tail text prefix))))))))))) (loop (list-tail text prefix)))))))))))
(display (string-join (map dec->hex text) " ")))) (display (string-join (map dec->hex text) " "))))
((member (car o) '(#:comment)) ((member (car o) '(#:comment))
(format #t "# ~a" (cadr o))) (format #t "# ~s" (cadr o)))
((eq? (car o) #:label) ((eq? (car o) #:label)
(format #t ":~a\n" (cadr o))) (format #t ":local_~a_~a\n" function (cadr o)))
((and (pair? (car o)) (eq? (caar o) #:label)) ((and (pair? (car o)) (eq? (caar o) #:label))
(format #t ":~a\n" (cadar o))) (format #t ":local_~a\n" (cadar o)))
((and (pair? (car o)) (member (caar o) '(#:comment))) ((and (pair? (car o)) (member (caar o) '(#:comment)))
(format #t "# ~a" (cadar o))) (format #t "# ~s" (cadar o)))
((and (pair? (car o)) (member (caar o) '(#:comment #:label))) ((and (pair? (car o)) (member (caar o) '(#:comment #:label)))
(write (car o))) (write (car o)))
(else (error "write-line LINE:" o)))) (else (error "write-line LINE:" o)))))
(define (write-function o) (define (write-function o)
(format #t "\n\n:~a" (car o)) (format #t "\n\n:~a" (car o))
(if (pair? (cadr o)) (for-each write-line (cdr o)) (if (pair? (cadr o)) (for-each (write-line (car o)) (cdr o))
(write-line (cdr o)))) ((write-line (car o)) (cdr o))))
(define (write-global o) (define (write-global o)
(let ((label (if (not (and (pair? (car o)) (eq? (caar o) #:string))) (car o) (define (labelize o)
(string->label (car o))))) (if (not (string? o)) o
(let* ((label o)
(function? (member label function-names))
(string-label (string->label label))
(string? (not (equal? string-label "string_#f")))
(global? (member label global-names)))
(if (or global? string?) (format #f "&~a" label)
(begin (if (not function?) (stderr "warning: unresolved label: ~s\n" label))
(format #f "&~a" label))))))
(let* ((label (if (not (and (pair? (car o)) (eq? (caar o) #:string))) (car o)
(string->label (car o))))
(data (cdr o))
(data (filter-map labelize data)))
(format #t "\n:~a\n" label) (format #t "\n:~a\n" label)
(display (string-join (map dec->hex (cdr o)) " ")) (display (string-join (map dec->hex data) " "))
(newline))) (newline)))
(display "### stage0's hex2 format for x86\n") (display "### stage0's hex2 format for x86\n")
(display "### !<label> 1 byte relative\n") (display "### !<label> 1 byte relative\n")

6
scaffold/t.c
View file

@ -76,7 +76,6 @@ SCM cell_fun;
char *env[] = {"foo", "bar", "baz", 0}; char *env[] = {"foo", "bar", "baz", 0};
#if 1
int int
add (int a, int b) add (int a, int b)
{ {
@ -95,6 +94,7 @@ identity (int i)
return i; return i;
} }
#if 1
int int
label (int c) label (int c)
{ {
@ -584,7 +584,9 @@ void
void_func () void_func ()
{ {
} }
#endif
#if 1
int int
test (char *p) test (char *p)
{ {
@ -809,7 +811,7 @@ test (char *p)
puts ("t: while (1) ... break;\n"); puts ("t: while (1) ... break;\n");
while (1) {f=0;break;} while (1) {f=0;break;}
puts ("t: while (1) ... break;\n"); puts ("t: while (1) {while (1) break;break;}\n");
while (1) {while (1) break;break;} while (1) {while (1) break;break;}
puts ("t: while (1) { goto label; };\n"); puts ("t: while (1) { goto label; };\n");

4
stage0/elf32.hex2
View file

@ -61,8 +61,8 @@
#65 01 00 00 # p_filesz #65 01 00 00 # p_filesz
#65 01 00 00 # p_memsz #65 01 00 00 # p_memsz
00 20 00 00 # p_filesz ff ff 00 00 # p_filesz
00 20 00 00 # p_memsz ff ff 00 00 # p_memsz
07 00 00 00 # p_flags 07 00 00 00 # p_flags