mes/module/mescc/M1.scm
Jan Nieuwenhuizen 7a8a2fc517
mescc: x86_64 support: Refactor to abstracted assembly, add x86_64.
* module/mescc/as.scm: Support abstracted assembly.
* module/mescc/i386/as.scm: Rewrite.
* module/mescc/x86_64/as.scm: Implement.
* module/mescc/compile.scm: Refactor to abstracted assembly.
* module/mescc/M1.scm: Update for partial 64 bit support.
* module/mescc/bytevectors.scm (bytevector-u64-native-set!): New
procedure.
* module/mescc/i386/info.scm (i386:type-alist): Use 4 byte type length
also for faking double, long long, long double.
* module/mescc/info.scm:modified:
* module/mescc/x86_64/info.scm (x86_64:registers): New variable.
* lib/x86-mes/x86.M1: Update for new register scheme.
* lib/x86_64-mes/x86_64.M1: Implement.
* lib/x86-mes/setjmp.c: Implement.
* lib/x86_64-mes-gcc/setjmp.c: Implement.
* build-aux/build-cc.sh: Update for x86_64.
* build-aux/build-cc32.sh: Likewise.
* build-aux/build-mes.sh: Likewise.
* build-aux/build-x86_64-mes.sh: Likewise.
* build-aux/check-mescc.sh: Likewise.
* build-aux/test64.sh: Likewise.
* include/libmes.h: Likewise.
* include/setjmp.h: Likewise.
* include/signal.h: Likewise.
* include/stdarg.h: Likewise.
* include/sys/stat.h: Likewise.
* include/sys/types.h: Likewise.
* include/sys/wait.h: Likewise.
* include/unistd.h: Likewise.
* lib/libc+gnu.c: Likewise.
* lib/libc+tcc.c: Likewise.
* lib/linux/gnu.c: Likewise.
* lib/linux/libc-mini.c: Likewise.
* lib/linux/libc.c: Likewise.
* lib/linux/tcc.c: Likewise.
* lib/linux/x86_64-mes-gcc/mes.c: Likewise.
* lib/linux/x86_64-mes/crt1.c: Likewise.
* lib/mes/abtol.c: Likewise.
* lib/posix/mktemp.c: Likewise.
* lib/posix/wait.c: Likewise.
* lib/stdio/fopen.c: Likewise.
* lib/stdio/fputc.c: Likewise.
* lib/stdio/fseek.c: Likewise.
* lib/stdio/printf.c: Likewise.
* lib/stdio/sprintf.c: Likewise.
* lib/stdio/vfprintf.c: Likewise.
* lib/stdio/vsprintf.c: Likewise.
* lib/stdio/vsscanf.c: Likewise.
* lib/stdlib/qsort.c: Likewise.
* lib/x86-mes-gcc/setjmp.c: Likewise.
* scaffold/tests/11-if-1.c: Likewise.
* scaffold/tests/15-if-!f.c: Likewise.
* scaffold/tests/16-if-t.c: Likewise.
* scaffold/tests/21-char[].c: Likewise.
* scaffold/tests/23-pointer.c: Likewise.
* scaffold/tests/32-compare.c: Likewise.
* scaffold/tests/33-and-or.c: Likewise.
* scaffold/tests/34-pre-post.c: Likewise.
* scaffold/tests/35-compare-char.c: Likewise.
* scaffold/tests/36-compare-arithmetic.c: Likewise.
* scaffold/tests/37-compare-assign.c: Likewise.
* scaffold/tests/38-compare-call.c: Likewise.
* scaffold/tests/40-if-else.c: Likewise.
* scaffold/tests/41-?.c: Likewise.
* scaffold/tests/42-goto-label.c: Likewise.
* scaffold/tests/43-for-do-while.c: Likewise.
* scaffold/tests/44-switch.c: Likewise.
* scaffold/tests/45-void-call.c: Likewise.
* scaffold/tests/46-function-static.c: Likewise.
* scaffold/tests/51-strcmp.c: Likewise.
* scaffold/tests/51-strncmp.c: Likewise.
* scaffold/tests/53-strcpy.c: Likewise.
* scaffold/tests/54-argv.c: Likewise.
* scaffold/tests/60-math.c: Likewise.
* scaffold/tests/61-array.c: Likewise.
* scaffold/tests/63-struct-cell.c: Likewise.
* scaffold/tests/64-make-cell.c: Likewise.
* scaffold/tests/65-read.c: Likewise.
* scaffold/tests/70-printf.c: Likewise.
* scaffold/tests/71-struct-array.c: Likewise.
* scaffold/tests/72-typedef-struct-def.c: Likewise.
* scaffold/tests/74-multi-line-string.c: Likewise.
* scaffold/tests/76-pointer-arithmetic.c: Likewise.
* scaffold/tests/79-int-array.c: Likewise.
* scaffold/tests/7a-struct-char-array.c: Likewise.
* scaffold/tests/7b-struct-int-array.c: Likewise.
* scaffold/tests/7i-struct-struct.c: Likewise.
* scaffold/tests/7k-for-each-elem.c: Likewise.
* scaffold/tests/7l-struct-any-size-array.c: Likewise.
* scaffold/tests/7o-struct-pre-post.c: Likewise.
* scaffold/tests/7q-bit-field.c: Likewise.
* scaffold/tests/7s-struct-short.c: Likewise.
* scaffold/tests/80-setjmp.c: Likewise.
* scaffold/tests/81-qsort.c: Likewise.
* scaffold/tests/85-sizeof.c: Likewise.
* scaffold/tests/87-sscanf.c: Likewise.
* scaffold/tests/90-strpbrk.c: Likewise.
* scaffold/tests/91-fseek.c: Likewise.
* scaffold/tests/95-signal.c: Likewise.
* scaffold/tests/97-fopen.c: Likewise.
* scaffold/tests/99-readdir.c: Likewise.
* scaffold/tests/t.c: Likewise.
* lib/linux/x86_64-mes/mes.c: New file.
* lib/linux/x86_64-mes/mini.c: New file.
* lib/x86_64-mes/setjmp.c: New file.
* scaffold/tests/06-!call-1.c: New file.
* scaffold/tests/06-call-2.c: New file.
* scaffold/tests/06-call-variable.c: New file.
* scaffold/tests/08-assign-global.c: New file.
* scaffold/tests/08-assign-negative.c: New file.
* scaffold/tests/17-compare-and-or.c: New file.
* scaffold/tests/17-compare-and.c: New file.
* scaffold/tests/17-compare-ge.c: New file.
* scaffold/tests/17-compare-gt.c: New file.
* scaffold/tests/17-compare-le.c: New file.
* scaffold/tests/17-compare-lt.c: New file.
* scaffold/tests/17-compare-or.c: New file.
* scaffold/tests/17-compare-unsigned-ge.c: New file.
* scaffold/tests/17-compare-unsigned-gt.c: New file.
* scaffold/tests/17-compare-unsigned-le.c: New file.
* scaffold/tests/17-compare-unsigned-lt.c: New file.
* scaffold/tests/21-char[]-simple.c: New file.
* scaffold/tests/23-global-pointer-init-null.c: New file.
* scaffold/tests/23-global-pointer-init.c: New file.
* scaffold/tests/23-global-pointer-pointer-ref.c: New file.
* scaffold/tests/23-global-pointer-ref.c: New file.
* scaffold/tests/23-pointer-sub.c: New file.
* scaffold/tests/31-oputs.c: New file.
* scaffold/tests/32-call-wrap.c: New file.
* scaffold/tests/38-compare-call-2.c: New file.
* scaffold/tests/38-compare-call-3.c: New file.
* scaffold/tests/51-pointer-sub.c: New file.
* scaffold/tests/54-argc.c: New file.
* scaffold/tests/63-struct-array-assign.c: New file.
* scaffold/tests/63-struct-array-compare.c: New file.
* scaffold/tests/63-struct-array.c: New file.
* scaffold/tests/63-struct-assign.c: New file.
* scaffold/tests/63-struct-function.c: New file.
* scaffold/tests/63-struct-local.c: New file.
* scaffold/tests/63-struct-pointer.c: New file.
* scaffold/tests/63-struct.c: New file.
* scaffold/tests/70-printf-hello.c: New file.
* scaffold/tests/70-printf-simple.c: New file.
* scaffold/tests/70-stdarg.c: New file.
* scaffold/tests/70-strchr.c: New file.
* scaffold/tests/73-union-hello.c: New file.
* scaffold/tests/76-pointer-arithmetic-pp.c: New file.
* scaffold/tests/79-int-array-simple.c: New file.
* scaffold/tests/7b-struct-int-array-hello.c: New file.
* scaffold/tests/7b-struct-int-array-pointer.c: New file.
* scaffold/tests/7i-struct-struct-simple.c: New file.
* scaffold/tests/7k-for-each-elem-simple.c: New file.
* scaffold/tests/7l-struct-any-size-array-simple.c: New file.
* scaffold/tests/7o-struct-pre-post-simple.c: New file.
* scaffold/tests/7q-bit-field-simple.c: New file.
* scaffold/tests/90-strspn.c: New file.
* scaffold/tests/06-call-string.c.: Rename from 31-eputs.c.
* scaffold/tests/7t-function-destruct.c: Rename from 48-function-destruct.c.
* scaffold/tests/48-global-static.c: Rename from 49-global-static.c.
* scaffold/tests/55-char-array.c:renamed: Rename from 4a-char-array.c.
* scaffold/tests/51-itoa.c:r Rename from 52-itoa.c.
* include/signal.h:(struct sigaction):
2018-08-15 18:26:55 +02:00

205 lines
8.3 KiB
Scheme

;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU 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.
;;;
;;; GNU 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 GNU Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; M1.scm produces stage0' M1 assembly format
;;; Code:
(define-module (mescc M1)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (system base pmatch)
#:use-module (mes misc)
#:use-module (mes guile)
#:use-module (mescc as)
#:use-module (mescc info)
#:export (info->M1
infos->M1
M1:merge-infos))
(define (infos->M1 file-name infos)
(let ((info (fold M1:merge-infos (make <info>) infos)))
(info->M1 file-name info)))
(define (M1:merge-infos o info)
(clone info
#:functions (alist-add (.functions info) (.functions o))
#:globals (alist-add (.globals info) (.globals o))))
(define (alist-add a b)
(let* ((b-keys (map car b))
(a (filter (lambda (f) (or (cdr f) (not (member (car f) b-keys)))) a))
(a-keys (map car a)))
(append a (filter (lambda (e) (not (member (car e) a-keys))) b))))
(define (hex2:address o)
(string-append "&" o))
(define (hex2:offset o)
(string-append "%" o))
(define (hex2:offset1 o)
(string-append "!" o))
(define hex? #t)
(define (hex2:immediate o)
(if hex? (string-append "%0x" (dec->hex o))
(string-append "%" (number->string o))))
(define (hex2:immediate1 o)
(if hex? (string-append "!0x" (dec->hex o))
(string-append "!" (number->string o))))
(define (hex2:immediate2 o)
(if hex? (string-append "@0x" (dec->hex o))
(string-append "@" (number->string o))))
(define (hex2:immediate4 o)
(if hex? (string-append "%0x" (dec->hex o))
(string-append "%" (number->string o))))
(define* (display-join o #:optional (sep ""))
(let loop ((o o))
(when (pair? o)
(display (car o))
(if (pair? (cdr o))
(display sep))
(loop (cdr o)))))
(define (info->M1 file-name o)
(let* ((functions (.functions o))
(function-names (map car functions))
(globals (.globals o))
(global-names (map car globals))
(strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names)))
(define (string->label o)
(let ((index (list-index (lambda (s) (equal? s o)) strings)))
(if index
(string-append "_string_" file-name "_" (number->string index))
(if (equal? o "%0") o ; FIXME: 64b
(error "no such string:" o)))))
(define (text->M1 o)
(cond
((char? o) (text->M1 (char->integer o)))
((string? o) o)
((symbol? o) (symbol->string o))
((number? o) (let ((o (if (< o #x80) o (- o #x100))))
(if hex? (string-append "!0x"
(if (and (>= o 0) (< o 16)) "0" "")
(number->string o 16))
(string-append "!" (number->string o)))))
((and (pair? o) (keyword? (car o)))
(pmatch o
;; FIXME
((#:address (#:string ,string)) (hex2:address (string->label `(#:string ,string))))
((#:address (#:address ,address)) (guard (string? address))
(hex2:address address))
((#:address (#:address ,global)) (guard (global? global))
(hex2:address (global->string global)))
((#:address ,function) (guard (function? function))
(hex2:address (function->string function)))
((#:address ,number) (guard (number? number))
(string-join (map text->M1 (int->bv32 number))))
((#:string ,string)
(hex2:address (string->label o)))
((#:address ,address) (guard (string? address)) (hex2:address address))
((#:address ,global) (guard (global? global))
(hex2:address (global->string global)))
((#:offset ,offset) (hex2:offset offset))
((#:offset1 ,offset1) (hex2:offset1 offset1))
((#:immediate ,immediate) (hex2:immediate immediate))
((#:immediate1 ,immediate1) (hex2:immediate1 immediate1))
((#:immediate2 ,immediate2) (hex2:immediate2 immediate2))
((#:immediate4 ,immediate4) (hex2:immediate4 immediate4))
(_ (error "text->M1 no match o" o))))
((pair? o) (string-join (map text->M1 o)))))
(define (write-function o)
(let ((name (car o))
(text (function:text (cdr o))))
(define (line->M1 o)
(cond ((eq? (car o) #:label)
(display (string-append ":" (cadr o))))
((eq? (car o) #:comment)
(display "\t\t\t\t\t# ")
(display (text->M1 (cadr o))))
((or (string? (car o)) (symbol? (car o)))
(display "\t" )
(display-join (map text->M1 o) " "))
(else (error "line->M1 invalid line:" o)))
(newline))
(display (string-append " :" name "\n") (current-error-port))
(display (string-append "\n\n:" name "\n"))
(for-each line->M1 (apply append text))))
(define (write-global 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"))))
(cond ((and (pair? o) (global? (cdr o))) (string-append "&" (global->string o)))
((and (not string?) (not function?)) (stderr "warning: unresolved label: ~s\n" label))
((equal? string-label "%0") o) ;; FIXME: 64b
(else (string-append "&" label))))))
(define (display-align size)
(let ((alignment (- 4 (modulo size 4))))
(when (> 4 alignment 0)
(display " ")
(display-join (map text->M1 (map (const 0) (iota alignment))) " "))))
(let* ((label (cond
((and (pair? (car o)) (eq? (caar o) #:string))
(string->label (car o)))
((global? (cdr o)) (global->string (cdr o)))
(else (car o))))
(string? (string-prefix? "_string" label))
(foo (if (not (eq? (car (string->list label)) #\_))
(display (string-append " :" label "\n") (current-error-port))))
(data ((compose global:value cdr) o))
(data (filter-map labelize data))
(len (length data))
(string-max (or (and=> (getenv "M1_STRING_MAX") string->number) 256))
(string-data (and string? (list-head data (1- (length data))))))
(display (string-append "\n:" label "\n"))
(if (and string-data
(< len string-max)
(char? (car data))
(eq? (last data) #\nul)
(not (find (cut memq <> '(#\")) string-data))
(not (any (lambda (ch)
(or (and (not (memq ch '(#\tab #\newline)))
(< (char->integer ch) #x20))
(>= (char->integer ch) #x80))) string-data)))
(let ((text string-data))
(display (string-append "\"" (list->string string-data) "\""))
(display-align (1+ (length string-data))))
(let ((text (map text->M1 data)))
(display-join text " ")
(display-align (length text))))
(newline)))
(display "M1: functions\n" (current-error-port))
(for-each write-function (filter cdr functions))
(when (assoc-ref functions "main")
(display "\n\n:ELF_data\n") ;; FIXME
(display "\n\n:HEX2_data\n"))
(display "M1: globals\n" (current-error-port))
(for-each write-global globals)))