5bf3c92938
* 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.
188 lines
8.6 KiB
Scheme
188 lines
8.6 KiB
Scheme
;;; -*-scheme-*-
|
|
|
|
;;; Mes --- Maxwell Equations of Software
|
|
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
|
|
;;;
|
|
;;; This file is part of Mes.
|
|
;;;
|
|
;;; 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.
|
|
;;;
|
|
;;; 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 Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;;; compiler.mes produces an i386 binary from the C produced by
|
|
;;; Nyacc c99.
|
|
|
|
;;; Code:
|
|
|
|
(cond-expand
|
|
(guile)
|
|
(guile-2)
|
|
(mes
|
|
(mes-use-module (srfi srfi-1))
|
|
(mes-use-module (srfi srfi-1))))
|
|
|
|
|
|
(define (int->bv32 value)
|
|
(let ((bv (make-bytevector 4)))
|
|
(bytevector-u32-native-set! bv 0 value)
|
|
bv))
|
|
|
|
(define (int->bv16 value)
|
|
(let ((bv (make-bytevector 2)))
|
|
(bytevector-u16-native-set! bv 0 value)
|
|
bv))
|
|
|
|
(define (make-global name type pointer value)
|
|
(cons name (list type pointer value)))
|
|
|
|
(define global:type car)
|
|
(define global:pointer cadr)
|
|
(define global:value caddr)
|
|
|
|
(define (dec->hex o)
|
|
(cond ((number? o) (number->string o 16))
|
|
((char? o) (number->string (char->integer o) 16))
|
|
(else (format #f "~s" o))))
|
|
|
|
(define (functions->lines functions)
|
|
(filter (lambda (x) (not (and (pair? x) (pair? (car x)) (member (caar x) '(#:comment #:label))))) (append-map cdr functions))
|
|
;;(append-map cdr functions)
|
|
)
|
|
|
|
(define (text->list o)
|
|
(append-map cdr o))
|
|
|
|
(define functions->text
|
|
(let ((cache '()))
|
|
(lambda (functions globals ta t d)
|
|
(let ((text (or (assoc-ref cache (cons ta (map car functions)))
|
|
(let ((text (apply append (functions->lines functions))))
|
|
(set! cache (assoc-set! cache (cons ta (map car functions)) text))
|
|
text))))
|
|
(if (= ta 0) text
|
|
(let loop ((f functions))
|
|
(if (null? f) '()
|
|
(append ((function->text functions globals ta t d) (car f))
|
|
(loop (cdr f))))))))))
|
|
|
|
(define (function->text functions globals ta t d)
|
|
(lambda (o)
|
|
(let ((text (apply append (cdr o)))
|
|
(offset (function-offset (car o) functions)))
|
|
(let loop ((text text) (off offset))
|
|
(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 (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
|
|
;;(member name (reverse functions) (lambda (a b) (equal? (car b) name)))
|
|
(let* ((x functions)
|
|
(x (if (and (pair? x) (equal? (caar x) "_start")) (reverse x) x)))
|
|
(member name x (lambda (a b) (equal? (car b) name)))))
|
|
|
|
(define function-offset
|
|
(let ((cache '()))
|
|
(lambda (name functions)
|
|
(or (assoc-ref cache name)
|
|
(let* ((functions (if (and (pair? functions) (equal? (caar functions) "_start")) functions (reverse functions)))
|
|
(prefix (and=> (function-prefix name functions) cdr))
|
|
(offset (and prefix
|
|
(if (null? prefix) 0
|
|
(+ (length (functions->text (list (car prefix)) '() 0 0 0))
|
|
(if (null? (cdr prefix)) 0
|
|
(function-offset (caar prefix) functions)))))))
|
|
(if (and offset (or (equal? name "_start") (> offset 0))) (set! cache (assoc-set! cache name offset)))
|
|
offset)))))
|
|
|
|
(define label-offset
|
|
(let ((cache '()))
|
|
(lambda (function label functions)
|
|
(or (assoc-ref cache (cons function label))
|
|
(let ((prefix (function-prefix function functions)))
|
|
(if (not prefix) 0
|
|
(let* ((function-entry (car prefix))
|
|
(offset (let loop ((text (cdr function-entry)))
|
|
;; FIXME: unresolved label
|
|
;;(if (null? text) (error "unresolved label:"))
|
|
(if (or (null? text) (equal? (car text) label)) 0
|
|
(let* ((t (car text))
|
|
(n (if (and (pair? (car t))
|
|
(member (caar t) '(#:label #:comment))) 0 (length t))))
|
|
(+ (loop (cdr text)) n))))))
|
|
(when (> offset 0)
|
|
(set! cache (assoc-set! cache (cons function label) offset)))
|
|
offset)))))))
|
|
|
|
(define (globals->data functions globals t d)
|
|
(let loop ((text (append-map cdr globals)))
|
|
(if (null? text) '()
|
|
(let ((label (car text)))
|
|
(if (or (char? label) (number? label)) (cons label (loop (cdr text)))
|
|
(let* ((prefix (if (and (pair? (cdr text))
|
|
(pair? (cddr text))
|
|
(boolean? (caddr text))) 4
|
|
2))
|
|
(function-address (function-offset label functions))
|
|
(data-address (data-offset label globals))
|
|
(address (or (and=> data-address (lambda (a) (+ a d)))
|
|
(and=> function-address (lambda (a) (+ a t)))
|
|
(error "unresolved label: " label))))
|
|
(append ((if (= prefix 2) int->bv16 int->bv32) address)
|
|
(loop (list-tail text prefix)))))))))
|
|
|
|
(define (simple-globals->data globals)
|
|
(append-map cdr globals))
|
|
|
|
(define data-offset
|
|
(let ((cache '()))
|
|
(lambda (name globals)
|
|
(or (assoc-ref cache name)
|
|
(let ((prefix (member name (reverse globals)
|
|
(lambda (a b)
|
|
(equal? (car b) name)))))
|
|
(and prefix
|
|
(let ((offset (length (simple-globals->data (cdr prefix)))))
|
|
(set! cache (assoc-set! cache name offset))
|
|
offset)))))))
|