mescc: Remove ELF creation, handled by hex2 now.

* module/language/c99/compiler.scm (make-global, global:type,
  global:pointer, global:value): Move from elf-util.mes
* module/mes/as.mes: New file.
* module/mes/as-i386.mes: Use it.
* module/mes/as-i386.scm: Use it.
* module/mes/elf-util.mes: Remove.
* module/mes/elf.mes (elf32-addr, elf32-half, elf32-off, elf32-word,
  make-elf, write-any, object->elf): Remove
  (hex2->elf): New function with dummy implementation.
* module/mes/elf.scm: Update exports.
* module/mes/hex2.mes (object->elf): New function.
* module/mes/hex2.scm: Export it.
This commit is contained in:
Jan Nieuwenhuizen 2017-06-25 09:26:25 +02:00
parent 1de0f33020
commit c44df4ed8a
11 changed files with 75 additions and 495 deletions

View file

@ -33,7 +33,7 @@
(mes-use-module (mes pmatch)) (mes-use-module (mes pmatch))
(mes-use-module (nyacc lang c99 parser)) (mes-use-module (nyacc lang c99 parser))
(mes-use-module (nyacc lang c99 pprint)) (mes-use-module (nyacc lang c99 pprint))
(mes-use-module (mes elf-util)) (mes-use-module (mes as))
(mes-use-module (mes as-i386)) (mes-use-module (mes as-i386))
(mes-use-module (mes hex2)) (mes-use-module (mes hex2))
(mes-use-module (mes optargs)))) (mes-use-module (mes optargs))))
@ -262,6 +262,13 @@
(wrap-as (i386:push-byte-local-de-de-ref (local:id o))) (wrap-as (i386:push-byte-local-de-de-ref (local:id o)))
(error "TODO int-de-de-ref"))))) (error "TODO int-de-de-ref")))))
(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 (string->global string) (define (string->global string)
(make-global `(#:string ,string) "string" 0 (append (string->list string) (list #\nul)))) (make-global `(#:string ,string) "string" 0 (append (string->list string) (list #\nul))))

View file

@ -28,9 +28,9 @@
#:use-module (system base pmatch) #:use-module (system base pmatch)
#:use-module (ice-9 optargs) #:use-module (ice-9 optargs)
#:use-module (ice-9 pretty-print) #:use-module (ice-9 pretty-print)
#:use-module (mes elf-util) #:use-module (mes as)
#:use-module (mes elf)
#:use-module (mes as-i386) #:use-module (mes as-i386)
#:use-module (mes elf)
#:use-module (mes hex2) #:use-module (mes hex2)
#:use-module (nyacc lang c99 parser) #:use-module (nyacc lang c99 parser)
#:use-module (nyacc lang c99 pprint) #:use-module (nyacc lang c99 pprint)

View file

@ -28,7 +28,7 @@
(guile-2) (guile-2)
(guile) (guile)
(mes (mes
(mes-use-module (mes elf-util)))) (mes-use-module (mes as))))
(define (i386:function-preamble) (define (i386:function-preamble)
'(#x55 ; push %ebp '(#x55 ; push %ebp

View file

@ -25,7 +25,7 @@
;;; Code: ;;; Code:
(define-module (mes as-i386) (define-module (mes as-i386)
#:use-module (mes elf-util) #:use-module (mes as)
#:export ( #:export (
i386:accu-not i386:accu-not
i386:accu-cmp-value i386:accu-cmp-value

48
module/mes/as.mes Normal file
View file

@ -0,0 +1,48 @@
;;; -*-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 (mes bytevectors))))
(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 (dec->hex o)
(cond ((number? o) (number->string o 16))
((char? o) (number->string (char->integer o) 16))
(else (format #f "~s" o))))

View file

@ -22,24 +22,12 @@
;;; Code: ;;; Code:
(define-module (mes elf-util) (define-module (mes as)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (mes bytevectors) #:use-module (mes bytevectors)
#:export (data-offset #:export (dec->hex
dec->hex
function-offset
int->bv16 int->bv16
int->bv32 int->bv32))
label-offset
functions->lambdas
functions->text
lambda/label->list
text->list
globals->data
make-global
global:type
global:pointer
global:value))
(cond-expand (cond-expand
(guile-2) (guile-2)
@ -47,4 +35,4 @@
(use-modules (ice-9 syncase))) (use-modules (ice-9 syncase)))
(mes)) (mes))
(include-from-path "mes/elf-util.mes") (include-from-path "mes/as.mes")

View file

@ -1,187 +0,0 @@
;;; -*-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)))))))

View file

@ -26,284 +26,7 @@
(cond-expand (cond-expand
(guile) (guile)
(mes (mes))
(mes-use-module (srfi srfi-1))
(mes-use-module (mes elf-util))))
(define elf32-addr int->bv32) (define (hex2->elf objects)
(define elf32-half int->bv16) (error "->ELF support dropped, use hex2"))
(define elf32-off int->bv32)
(define elf32-word int->bv32)
(define (make-elf functions globals init)
(define vaddress #x08048000)
(define ei-magic `(#x7f ,@(string->list "ELF")))
(define ei-class '(#x01)) ;; 32 bit
(define ei-data '(#x01)) ;; little endian
(define ei-version '(#x01))
(define ei-osabi '(#x00))
(define ei-pad '(#x0 #x0 #x0 #x0 #x0 #x0 #x0 #x0))
(define e-ident
(append
ei-magic
ei-class
ei-data
ei-version
ei-osabi
ei-pad))
(define ET-EXEC 2)
(define EM-386 3)
(define EV-CURRENT 1)
(define p-filesz (elf32-word 0))
(define p-memsz (elf32-word 0))
(define PF-X 1)
(define PF-W 2)
(define PF-R 4)
(define p-flags (elf32-word (logior PF-X PF-W PF-R)))
(define p-align (elf32-word 1))
(define (program-header type offset text)
(append
(elf32-word type)
(elf32-off offset)
(elf32-addr (+ vaddress offset))
(elf32-addr (+ vaddress offset))
(elf32-word (length text))
(elf32-word (length text))
p-flags
p-align
))
(define (section-header name type flags offset text sh-link sh-info sh-entsize)
(append
(elf32-word name)
(elf32-word type)
;;;;(elf32-word 3) ;; write/alloc must for data hmm
(elf32-word flags)
(elf32-addr (+ vaddress offset))
(elf32-off offset)
(elf32-word (length text))
(elf32-word sh-link)
(elf32-word sh-info)
(elf32-word 1)
(elf32-word sh-entsize)))
(define e-type (elf32-half ET-EXEC))
(define e-machine (elf32-half EM-386))
(define e-version (elf32-word EV-CURRENT))
(define e-entry (elf32-addr 0))
;;(define e-entry (elf32-addr (+ vaddress text-offset)))
;;(define e-phoff (elf32-off 0))
(define e-shoff (elf32-off 0))
(define e-flags (elf32-word 0))
;;(define e-ehsize (elf32-half 0))
(define e-phentsize (elf32-half (length (program-header 0 0 '()))))
(define e-phnum (elf32-half 2)) ; text+data
(define e-shentsize (elf32-half (length (section-header 0 0 0 0 '() 0 0 0))))
(define e-shnum (elf32-half 7)) ; sections: 7
(define e-shstrndx (elf32-half 4))
(define (elf-header size entry sections)
(append
e-ident
e-type
e-machine
e-version
(elf32-addr (+ vaddress entry)) ;; e-entry
(elf32-off size) ;; e-phoff
(elf32-off sections) ;; e-shoff
e-flags
(elf32-half size) ;; e-ehsize
e-phentsize
e-phnum
e-shentsize
e-shnum
e-shstrndx
))
(define elf-header-size
(length (elf-header 0 0 0)))
(define program-header-size
(* 2 (length (program-header 0 0 '()))))
(define text-offset
(+ elf-header-size program-header-size))
(define PT-LOAD 1)
(define (program-headers text data)
(append
(program-header PT-LOAD text-offset text)
(program-header PT-LOAD data-offset data)))
(define comment
(string->list
(string-append
"MES"
;;"Mes -- Maxwell Equations of Software\n"
;;"https://gitlab.com/janneke/mes"
)
;; #x05 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x02 #x00 #x00 #x00
;; #\i #\3 #\8 #\6 #x00 #x00 #x00 #x00
))
(define shstr
`(
#x00 ; 0
,@(string->list ".text") #x00 ; 1
,@(string->list ".data") #x00 ; 7
,@(string->list ".comment") #x00 ; 13
,@(string->list ".shstrtab") #x00 ; 22
,@(string->list ".symtab") #x00 ; 32
,@(string->list ".strtab") #x00 ; 40
))
(define (str functions)
(cons
0
(append-map
(lambda (s) (append (string->list s) (list 0)))
(map car functions))))
(define text-length
(length (functions->text functions globals 0 0 0)))
(define data-offset
(+ text-offset text-length))
(define stt-func 2)
(define stt-global-func 18)
(define (symbol-table-entry st-name st-offset st-length st-info st-other st-shndx)
(append
(elf32-word st-name)
(elf32-addr st-offset)
(elf32-word st-length)
(list st-info)
(list st-other)
(elf32-half st-shndx)))
(define (sym functions globals)
(define (symbol->table-entry o)
(let* ((name (car o))
(offset (function-offset name functions))
(len (if (not (cdr o)) 0 (length (text->list (cddr o)))))
(str (append-map (lambda (x) (cons 0 (string->list x))) (cdr (member name (reverse (map car functions))))))
(i (1+ (length str))))
(symbol-table-entry i (+ vaddress text-offset offset) len stt-func 0 1)))
(append
(symbol-table-entry 0 0 0 0 0 0)
(append-map symbol->table-entry functions)))
(define data-address (+ data-offset vaddress))
(define text-address (+ text-offset vaddress))
(define data-length
(length (globals->data functions globals 0 0)))
(define comment-length
(length comment))
(define comment-offset
(+ data-offset data-length))
(define shstr-offset
(+ comment-offset comment-length))
(define shstr-length
(length shstr))
(define sym-offset
(+ shstr-offset shstr-length))
(define SHT-PROGBITS 1)
(define SHT-SYMTAB 2)
(define SHT-STRTAB 3)
(define SHT-NOTE 7)
(define SHF-WRITE 1)
(define SHF-ALLOC 2)
(define SHF-EXEC 4)
(define SHF-STRINGS #x20)
(let* ((text (functions->text functions globals text-address 0 data-address))
(raw-data (globals->data functions globals text-address data-address))
;; (data (let loop ((data raw-data) (init init))
;; (if (null? init) data
;; (loop ((car init) functions globals text-address 0 data-address data) (cdr init)))))
(data raw-data)
(entry (+ text-offset (function-offset "_start" functions)))
(sym (sym functions globals))
(str (str functions)))
(define (section-headers)
(append
(section-header 0 0 0 0 '() 0 0 0)
(section-header 1 SHT-PROGBITS (logior SHF-ALLOC SHF-EXEC) text-offset text 0 0 0)
(section-header 7 SHT-PROGBITS (logior SHF-ALLOC SHF-WRITE) data-offset data 0 0 0)
(section-header 13 SHT-PROGBITS 0 comment-offset comment 0 0 0)
(section-header 22 SHT-STRTAB 0 shstr-offset shstr 0 0 0)
(section-header 32 SHT-SYMTAB 0 sym-offset sym 6 0 (length (symbol-table-entry 0 0 0 0 9 0)))
(section-header 40 SHT-STRTAB 0 str-offset str 0 0 0)))
(define sym-length
(length sym))
(define str-offset
(+ sym-offset sym-length))
(define str-length
(length str))
(define section-headers-offset
(+ str-offset str-length))
(if (< (length text) 2000)
(format (current-error-port) "ELF text=~a\n" (map dec->hex text)))
(if (< (length raw-data) 200)
(format (current-error-port) "ELF raw-data=~a\n" (map dec->hex raw-data)))
(if (< (length data) 200)
(format (current-error-port) "ELF data=~a\n" (map dec->hex data)))
(format (current-error-port) "text-offset=~a\n" text-offset)
(format (current-error-port) "data-offset=~a\n" data-offset)
(format (current-error-port) "_start=~a\n" (number->string entry 16))
(append
(elf-header elf-header-size entry section-headers-offset)
(program-headers text data)
text
data
comment
shstr
sym
str
(section-headers))))
(define (logf port string . rest)
(apply format (cons* port string rest))
(force-output port)
#t)
(define (stderr string . rest)
(apply logf (cons* (current-error-port) string rest)))
(define (write-any x)
(write-char
(cond ((char? x) x)
((and (number? x) (< (+ x 256) 0))
(format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa))
((number? x) (integer->char (if (>= x 0) x (+ x 256))))
((procedure? x)
(stderr "write-any: proc: ~a\n" x)
(stderr " ==> ~a\n" (map dec->hex (x '() '() 0 0)))
(error "procedure: write-any:" x))
(else (stderr "write-any: ~a\n" x) (error "write-any: else: " x)))))
(define (object->elf object)
(display "dumping elf\n" (current-error-port))
(for-each
write-any
(make-elf (filter cdr (assoc-ref object 'functions)) (assoc-ref object 'globals) (assoc-ref object 'inits))))

View file

@ -23,10 +23,7 @@
;;; Code: ;;; Code:
(define-module (mes elf) (define-module (mes elf)
#:use-module (srfi srfi-1) #:export (hex2->elf))
#:use-module (mes elf-util)
#:export (make-elf
object->elf))
(cond-expand (cond-expand
(guile-2) (guile-2)

View file

@ -28,7 +28,7 @@
(guile) (guile)
(mes (mes
(mes-use-module (srfi srfi-1)) (mes-use-module (srfi srfi-1))
(mes-use-module (mes elf-util)) (mes-use-module (mes as))
(mes-use-module (mes elf)) (mes-use-module (mes elf))
(mes-use-module (mes optargs)) (mes-use-module (mes optargs))
(mes-use-module (mes pmatch)))) (mes-use-module (mes pmatch))))
@ -44,8 +44,11 @@
(define (objects->hex2 objects) (define (objects->hex2 objects)
((compose object->hex2 merge-objects) objects)) ((compose object->hex2 merge-objects) objects))
(define (object->elf o)
((compose hex2->elf object->hex2) o))
(define (objects->elf objects) (define (objects->elf objects)
(error "->ELF support dropped, use hex2")) ((compose hex2->elf object->hex2 merge-objects) objects))
(define (merge-objects objects) (define (merge-objects objects)
(let loop ((objects (cdr objects)) (object (car objects))) (let loop ((objects (cdr objects)) (object (car objects)))

View file

@ -25,10 +25,11 @@
(define-module (mes hex2) (define-module (mes hex2)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (system base pmatch) #:use-module (system base pmatch)
#:use-module (mes elf-util) #:use-module (mes as)
#:use-module (mes elf) #:use-module (mes elf)
#:export (object->hex2 #:export (object->hex2
objects->hex2 objects->hex2
object->elf
objects->elf)) objects->elf))
(cond-expand (cond-expand