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

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

@ -84,33 +84,35 @@
(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 ((and (pair? (cdr text))
2)) (boolean? (cadr text))) 2)
;;(foo (format (current-error-port) "LABEL=~s\n" label)) (else 1)))
(address? (and (pair? label) (eq? (car label) #:address))) ;; (foo (format (current-error-port) "LABEL=~s\n" label))
(local? (and (pair? label) (eq? (car label) #:local))) ;; (foo (format (current-error-port) " prefix=~s\n" prefix))
(relative? (and (pair? label) (eq? (car label) #:relative))) (address? (and (pair? label) (eq? (car label) #:address)))
(label (if (or address? local? relative?) (cadr label) label)) (local? (and (pair? label) (eq? (car label) #:local)))
(function-address (function-offset label functions)) (relative? (and (pair? label) (eq? (car label) #:relative)))
(data-address (data-offset label globals)) (label (if (or address? local? relative?) (cadr label) label))
(label-address (label-offset (car o) `((#:label ,label)) functions)) (function-address (function-offset label functions))
;; (foo (format (current-error-port) " address?=~s\n" address?)) (data-address (data-offset label globals))
;; (foo (format (current-error-port) " d=~s\n" data-address)) (label-address (label-offset (car o) `((#:label ,label)) functions))
;; (foo (format (current-error-port) " f=~s\n" function-address)) ;; (foo (format (current-error-port) " address?=~s\n" address?))
;; (foo (format (current-error-port) " l=~s\n" label-address)) ;; (foo (format (current-error-port) " d=~s\n" data-address))
(address (or (and local? ;; (foo (format (current-error-port) " f=~s\n" function-address))
(and=> label-address (lambda (a) (- a (- off offset) prefix)))) ;; (foo (format (current-error-port) " l=~s\n" label-address))
(and=> data-address (lambda (a) (+ a d))) (address (or (and local?
(if address? (and=> label-address (lambda (a) (- a (- off offset) prefix))))
(and=> function-address (lambda (a) (+ a ta))) (and=> data-address (lambda (a) (+ a d)))
(and=> function-address (lambda (a) (- a off prefix)))) (if address?
(error "unresolved label: " label)))) (and=> function-address (lambda (a) (+ a ta)))
(append ((if (= prefix 2) int->bv16 int->bv32) address) (and=> function-address (lambda (a) (- a off prefix))))
(loop (list-tail text prefix) (+ off prefix)))))))))))) (error "unresolved label: " label))))
(append ((case prefix ((1) list) ((2) int->bv16) ((4) int->bv32)) address)
(loop (list-tail text prefix) (+ off prefix))))))))))))
(define (function-prefix name functions) (define (function-prefix name functions)
;; FIXME ;; FIXME

118
module/mes/hex2.mes
View file

@ -123,62 +123,80 @@
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)
(newline) (lambda (o)
(cond ((not (pair? o)) (newline)
(display (dec->hex o))) (cond ((not (pair? o))
((number? (car o)) (display (dec->hex o)))
;;(display (string-join (map dec->hex (filter identity o)) " ")) ((number? (car o))
(let ((text (let loop ((text o)) ;;(display (string-join (map dec->hex (filter identity o)) " "))
(if (null? text) '() ;; FIXME: c&p from elf-util: function->text
(let ((label (car text))) (let ((text (let loop ((text o))
(if (number? label) (cons label (loop (cdr text))) (if (null? text) '()
(if (and (pair? label) (member (car label) '(#:comment #:label))) (loop (cdr text)) (let ((label (car text)))
(let* ((prefix (if (and (pair? (cdr text)) (if (number? label) (cons label (loop (cdr text)))
(pair? (cddr text)) (if (and (pair? label) (member (car label) '(#:comment #:label))) (loop (cdr text))
(boolean? (caddr text))) 4 (let* ((prefix (cond ((and (pair? (cdr text))
2)) (pair? (cddr text))
(address? (and (pair? label) (eq? (car label) #:address))) (boolean? (caddr text))) 4)
(local? (and (pair? label) (eq? (car label) #:local))) ((and (pair? (cdr text))
(relative? (and (pair? label) (eq? (car label) #:relative))) (boolean? (cadr text))) 2)
(label (if (or address? local? relative?) (cadr label) label)) (else 1)))
(function? (member label function-names)) (address? (and (pair? label) (eq? (car label) #:address)))
(string-label (string->label label)) (local? (and (pair? label) (eq? (car label) #:local)))
(string? (not (equal? string-label "string_#f"))) (relative? (and (pair? label) (eq? (car label) #:relative)))
(global? (member label global-names))) (label (if (or address? local? relative?) (cadr label) label))
(cons (cond (function? (member label function-names))
((eq? prefix 1) (format #f "!~a" label)) (string-label (string->label label))
((eq? prefix 2) (format #f "@~a" label)) (string? (not (equal? string-label "string_#f")))
(local? (format #f "%local_~a" label)) (global? (member label global-names))
(function? (format #f "%~a" label)) (label (if local? (string-append "local_" function "_" label) label)))
(string? (format #f "&~a" string-label)) (cons (cond
(global? (format #f "&~a" label)) ((eq? prefix 1) (format #f "!~a" label))
(else (format #f "%~a" label))) ((eq? prefix 2) (format #f "@~a" label))
(loop (list-tail text prefix))))))))))) (local? (format #f "%~a" label))
(display (string-join (map dec->hex text) " ")))) (function? (if address? (format #f "&~a" label)
((member (car o) '(#:comment)) (format #f "%~a" label)))
(format #t "# ~a" (cadr o))) (string? (format #f "&~a" string-label))
((eq? (car o) #:label) (global? (format #f "&~a" label))
(format #t ":~a\n" (cadr o))) (else (format #f "%~a" label)))
((and (pair? (car o)) (eq? (caar o) #:label)) (loop (list-tail text prefix)))))))))))
(format #t ":~a\n" (cadar o))) (display (string-join (map dec->hex text) " "))))
((and (pair? (car o)) (member (caar o) '(#:comment))) ((member (car o) '(#:comment))
(format #t "# ~a" (cadar o))) (format #t "# ~s" (cadr o)))
((and (pair? (car o)) (member (caar o) '(#:comment #:label))) ((eq? (car o) #:label)
(write (car o))) (format #t ":local_~a_~a\n" function (cadr o)))
(else (error "write-line LINE:" o)))) ((and (pair? (car o)) (eq? (caar o) #:label))
(format #t ":local_~a\n" (cadar o)))
((and (pair? (car o)) (member (caar o) '(#:comment)))
(format #t "# ~s" (cadar o)))
((and (pair? (car o)) (member (caar o) '(#:comment #:label)))
(write (car 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