From 5bf3c929381caf576c2a5cda79dc30847aedba2c Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 12 Jun 2017 21:00:50 +0200 Subject: [PATCH] mescc: Remove jump calculation, use labels: prepare. * 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. --- module/language/c99/compiler.mes | 54 ++++++++++++++ module/mes/as-i386.mes | 21 ++++++ module/mes/as-i386.scm | 7 ++ module/mes/elf-util.mes | 56 ++++++++------- module/mes/hex2.mes | 118 ++++++++++++++++++------------- scaffold/t.c | 6 +- stage0/elf32.hex2 | 4 +- 7 files changed, 185 insertions(+), 81 deletions(-) diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes index 91e91877..ffda180c 100644 --- a/module/language/c99/compiler.mes +++ b/module/language/c99/compiler.mes @@ -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)) diff --git a/module/mes/as-i386.mes b/module/mes/as-i386.mes index b2f8065f..ae667d85 100644 --- a/module/mes/as-i386.mes +++ b/module/mes/as-i386.mes @@ -349,6 +349,27 @@ (define (i386:jump-label label) `(#xe9 ,label #f #f #f)) ; jmp . + +(define (i386:jump-label-z label) + `(#x0f #x84 ,label #f #f #f)) ; jz . + + +(define (i386:jump-label-byte-z label) + `(#x84 #xc0 ; test %al,%al + #x74 ,label)) ; jne + +;; signed +(define (i386:jump-label-g label) + `(#x0f #x8f ,label #f #f #f)) ; jg/jnle + +;; signed +(define (i386:jump-label-ge label) + `(#x0f #x8d ,label #f #f #f)) ; jge/jnl + +(define (i386:jump-label-nz label) + `(#x0f #x85 ,label #f #f #f)) ; jnz . + + +(define (i386:jump-label-z label) + `(#x0f #x84 ,label #f #f #f)) ; jz . + + (define (i386:Xjump-nz n) (or n (error "invalid value: i386:Xjump-nz: n: " n)) `(#x0f #x85 ,@(int->bv32 n))) ; jnz . + diff --git a/module/mes/as-i386.scm b/module/mes/as-i386.scm index b52a24ff..f324b8ca 100644 --- a/module/mes/as-i386.scm +++ b/module/mes/as-i386.scm @@ -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 diff --git a/module/mes/elf-util.mes b/module/mes/elf-util.mes index be67aa6e..5dd55a47 100644 --- a/module/mes/elf-util.mes +++ b/module/mes/elf-util.mes @@ -84,33 +84,35 @@ (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)) - (pair? (cddr text)) - (boolean? (caddr text))) 4 - 2)) - ;;(foo (format (current-error-port) "LABEL=~s\n" label)) - (address? (and (pair? label) (eq? (car label) #:address))) - (local? (and (pair? label) (eq? (car label) #:local))) - (relative? (and (pair? label) (eq? (car label) #:relative))) - (label (if (or address? local? relative?) (cadr label) label)) - (function-address (function-offset label functions)) - (data-address (data-offset label globals)) - (label-address (label-offset (car o) `((#:label ,label)) functions)) - ;; (foo (format (current-error-port) " address?=~s\n" address?)) - ;; (foo (format (current-error-port) " d=~s\n" data-address)) - ;; (foo (format (current-error-port) " f=~s\n" function-address)) - ;; (foo (format (current-error-port) " l=~s\n" label-address)) - (address (or (and local? - (and=> label-address (lambda (a) (- a (- off offset) prefix)))) - (and=> data-address (lambda (a) (+ a d))) - (if address? - (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) - (loop (list-tail text prefix) (+ off prefix)))))))))))) + (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) + ((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))) + (label (if (or address? local? relative?) (cadr label) label)) + (function-address (function-offset label functions)) + (data-address (data-offset label globals)) + (label-address (label-offset (car o) `((#:label ,label)) functions)) + ;; (foo (format (current-error-port) " address?=~s\n" address?)) + ;; (foo (format (current-error-port) " d=~s\n" data-address)) + ;; (foo (format (current-error-port) " f=~s\n" function-address)) + ;; (foo (format (current-error-port) " l=~s\n" label-address)) + (address (or (and local? + (and=> label-address (lambda (a) (- a (- off offset) prefix)))) + (and=> data-address (lambda (a) (+ a d))) + (if address? + (and=> function-address (lambda (a) (+ a ta))) + (and=> function-address (lambda (a) (- a 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) ;; FIXME diff --git a/module/mes/hex2.mes b/module/mes/hex2.mes index 2c5096a9..e311ff2f 100644 --- a/module/mes/hex2.mes +++ b/module/mes/hex2.mes @@ -123,62 +123,80 @@ 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) - (newline) - (cond ((not (pair? o)) - (display (dec->hex o))) - ((number? (car o)) - ;;(display (string-join (map dec->hex (filter identity o)) " ")) - (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)) - (pair? (cddr text)) - (boolean? (caddr text))) 4 - 2)) - (address? (and (pair? label) (eq? (car label) #:address))) - (local? (and (pair? label) (eq? (car label) #:local))) - (relative? (and (pair? label) (eq? (car label) #:relative))) - (label (if (or address? local? relative?) (cadr label) label)) - (function? (member label function-names)) - (string-label (string->label label)) - (string? (not (equal? string-label "string_#f"))) - (global? (member label global-names))) - (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)) - (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))) - ((eq? (car o) #:label) - (format #t ":~a\n" (cadr o))) - ((and (pair? (car o)) (eq? (caar o) #:label)) - (format #t ":~a\n" (cadar o))) - ((and (pair? (car o)) (member (caar o) '(#:comment))) - (format #t "# ~a" (cadar o))) - ((and (pair? (car o)) (member (caar o) '(#:comment #:label))) - (write (car o))) - (else (error "write-line 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 (cond ((and (pair? (cdr text)) + (pair? (cddr text)) + (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))) + (label (if (or address? local? relative?) (cadr label) label)) + (function? (member label function-names)) + (string-label (string->label label)) + (string? (not (equal? string-label "string_#f"))) + (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 "%~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 "# ~s" (cadr o))) + ((eq? (car o) #:label) + (format #t ":local_~a_~a\n" function (cadr 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) (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 "### !