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)))))
(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)
(cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
((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)
`(#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)
(or n (error "invalid value: i386:Xjump-nz: n: " 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-mem->accu
i386:label-mem->base
i386:jump
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-z
i386:jump-c

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

@ -84,13 +84,15 @@
(if (null? text) '()
(let ((label (car text)))
(if (number? label) (cons label (loop (cdr text) (1+ off)))
(if (and (pair? label) (member (car label) '(#:comment #:label)))
(loop (cdr text) off)
(let* ((prefix (if (and (pair? (cdr text))
(if (and (pair? label) (member (car label) '(#:comment #:label))) (loop (cdr text) off)
(let* ((prefix (cond ((and (pair? (cdr text))
(pair? (cddr text))
(boolean? (caddr text))) 4
2))
(boolean? (caddr text))) 4)
((and (pair? (cdr text))
(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)))
(local? (and (pair? label) (eq? (car label) #:local)))
(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 off prefix))))
(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))))))))))))
(define (function-prefix name functions)

54
module/mes/hex2.mes
View file

@ -123,24 +123,28 @@
16)))
((char? o) (dec->hex (char->integer o)))
((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))
(else (format #f "~a" o))))
(define (write-line o)
(define (write-line function)
(lambda (o)
(newline)
(cond ((not (pair? o))
(display (dec->hex o)))
((number? (car o))
;;(display (string-join (map dec->hex (filter identity o)) " "))
;; FIXME: c&p from elf-util: function->text
(let ((text (let loop ((text o))
(if (null? text) '()
(let ((label (car text)))
(if (number? label) (cons 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))
(boolean? (caddr text))) 4
2))
(boolean? (caddr text))) 4)
((and (pair? (cdr text))
(boolean? (cadr text))) 2)
(else 1)))
(address? (and (pair? label) (eq? (car label) #:address)))
(local? (and (pair? label) (eq? (car label) #:local)))
(relative? (and (pair? label) (eq? (car label) #:relative)))
@ -148,37 +152,51 @@
(function? (member label function-names))
(string-label (string->label label))
(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
((eq? prefix 1) (format #f "!~a" label))
((eq? prefix 2) (format #f "@~a" label))
(local? (format #f "%local_~a" label))
(function? (format #f "%~a" label))
(local? (format #f "%~a" label))
(function? (if address? (format #f "&~a" label)
(format #f "%~a" label)))
(string? (format #f "&~a" string-label))
(global? (format #f "&~a" label))
(else (format #f "%~a" label)))
(loop (list-tail text prefix)))))))))))
(display (string-join (map dec->hex text) " "))))
((member (car o) '(#:comment))
(format #t "# ~a" (cadr o)))
(format #t "# ~s" (cadr o)))
((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))
(format #t ":~a\n" (cadar o)))
(format #t ":local_~a\n" (cadar o)))
((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)))
(write (car o)))
(else (error "write-line LINE:" o))))
(else (error "write-line LINE:" o)))))
(define (write-function o)
(format #t "\n\n:~a" (car o))
(if (pair? (cadr o)) (for-each write-line (cdr o))
(write-line (cdr o))))
(if (pair? (cadr o)) (for-each (write-line (car o)) (cdr o))
((write-line (car o)) (cdr o))))
(define (write-global o)
(let ((label (if (not (and (pair? (car o)) (eq? (caar o) #:string))) (car o)
(string->label (car o)))))
(define (labelize 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)
(display (string-join (map dec->hex (cdr o)) " "))
(display (string-join (map dec->hex data) " "))
(newline)))
(display "### stage0's hex2 format for x86\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};
#if 1
int
add (int a, int b)
{
@ -95,6 +94,7 @@ identity (int i)
return i;
}
#if 1
int
label (int c)
{
@ -584,7 +584,9 @@ void
void_func ()
{
}
#endif
#if 1
int
test (char *p)
{
@ -809,7 +811,7 @@ test (char *p)
puts ("t: while (1) ... break;\n");
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;}
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_memsz
00 20 00 00 # p_filesz
00 20 00 00 # p_memsz
ff ff 00 00 # p_filesz
ff ff 00 00 # p_memsz
07 00 00 00 # p_flags