kylekrein/live-bootstrap
1
0
Fork 0
mirror of https://github.com/fosslinux/live-bootstrap.git synced 2026-03-13 14:55:24 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions 2

Add mes and mescc-tools-extra

Browse source 
mescc-tools-extra contains two important tools:
- cp
- chmod

mes first builds itself from a mes 0.21 seed as used by guix, and then
builds a mes 0.22 and then mes 0.22 using that created mes 0.22.

It does /not/ use bootstrap.sh as we don't have a proper shell at this
point, it has been manually adapted for kaem.
This commit is contained in:
fosslinux 2020-12-25 18:40:14 +11:00
parent 2706e07556
commit 649d7b68dc
1029 changed files with 120985 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

256
sysa/mes-0.22/module/mescc/M1.scm Normal file
View file

@ -0,0 +1,256 @@
;;; 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 #:key align? verbose?)
(let ((info (fold M1:merge-infos (make <info>) infos)))
(info->M1 file-name info #:align? align? #:verbose? verbose?)))
(define (M1:merge-infos o info)
(clone info
#:functions (alist-add (.functions info) (.functions o))
#:globals (alist-add (.globals info) (.globals o))
#:types (.types 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:address8 o)
(string-append "&" o " %0")) ;; FIXME: 64bit
(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 mesc? (string=? %compiler "mesc"))
(define (hex2:immediate8 o)
;; FIXME: #x100000000 => 0 divide-by-zero when compiled with 64 bit mesc
(if hex? (string-append "%0x" (dec->hex (if mesc? 0 (modulo o #x100000000)))
" %0x" (if (< o 0) "-1"
(dec->hex (if mesc? o (quotient o #x100000000)))))
(string-append "%" (number->string (dec->hex (if mesc? 0 (modulo o #x100000000))))
" %" (if (< o 0) "-1"
(number->string (dec->hex (if mesc? o (quotient o #x100000000))))))))
(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 (global-string? o)
(and (pair? o) (pair? (car o)) (eq? (caar o) #:string)))
(define (global-extern? o)
(and=> (global:storage o) (cut eq? <> 'extern)))
(define* (info->M1 file-name o #:key align? verbose?)
(let* ((functions (.functions o))
(function-names (map car functions))
(globals (.globals o))
(globals (filter (negate (compose global-extern? cdr)) globals))
(strings (filter global-string? globals))
(strings (map car strings))
(reg-size (type:size (assoc-ref (.types o) "*"))))
(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))))
((#:address8 (#:string ,string))
(hex2:address8 (string->label `(#:string ,string))))
((#:address8 (#:address ,address)) (guard (string? address))
(hex2:address8 address))
((#:address8 (#:address ,global)) (guard (global? global))
(hex2:address8 (global->string global)))
((#:address8 ,function) (guard (function? function))
(hex2:address8 (function->string function)))
((#:address8 ,number) (guard (number? number))
(string-join (map text->M1 (int->bv64 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)))
((#:address8 ,address) (guard (string? address))
(hex2:address8 address))
((#:address8 ,global) (guard (global? global))
(hex2:address8 (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))
((#:immediate8 ,immediate8) (hex2:immediate8 immediate8))
(_ (error "text->M1 no match o" o))))
((pair? o) (string-join (map text->M1 o)))
(#t (error "no such text:" 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))
(when verbose?
(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 (- reg-size (modulo size reg-size))))
(when (and align? (> reg-size alignment 0))
(display " ")
(display-join (map text->M1 (map (const 0) (iota alignment))) " "))
#t))
(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 (when (and verbose? (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)))
(when verbose?
(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"))
(when verbose?
(display "M1: globals\n" (current-error-port)))
(for-each write-global (filter global-string? globals))
(for-each write-global (filter (negate global-string?) globals))))

77
sysa/mes-0.22/module/mescc/as.scm Normal file
View file

@ -0,0 +1,77 @@
;;; 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/>.
(define-module (mescc as)
#:use-module (srfi srfi-1)
#:use-module (mes guile)
#:use-module (mescc bytevectors)
#:use-module (mescc info)
#:export (as
dec->hex
int->bv8
int->bv16
int->bv32
int->bv64
get-r
get-r0
get-r1
get-r-1))
(define (int->bv64 value)
(let ((bv (make-bytevector 8)))
(bytevector-u64-native-set! bv 0 value)
bv))
(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 (int->bv8 value)
(let ((bv (make-bytevector 1)))
(bytevector-u8-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))))
(define (as info instruction . rest)
(if (pair? instruction)
(append-map (lambda (o) (apply as (cons* info o rest))) instruction)
(let ((proc (assoc-ref (.instructions info) instruction)))
(if (not proc) (error "no such instruction" instruction)
(apply proc info rest)))))
(define (get-r info)
(car (if (pair? (.allocated info)) (.allocated info) (.registers info))))
(define (get-r0 info)
(cadr (.allocated info)))
(define (get-r1 info)
(car (.allocated info)))
(define (get-r-1 info)
(caddr (.allocated info)))

74
sysa/mes-0.22/module/mescc/bytevectors.scm Normal file
View file

@ -0,0 +1,74 @@
;;; 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:
;;; Code:
(define-module (mescc bytevectors)
#:use-module (mes guile)
#:export (bytevector-u64-native-set!
bytevector-u32-native-set!
bytevector-u16-native-set!
bytevector-u8-set!
make-bytevector))
;; rnrs compatibility
(define (bytevector-u64-native-set! bv index value)
(when (not (= 0 index)) (error "bytevector-u64-native-set! index not zero: " index " value: " value))
(let ((x (list
(modulo value #x100)
(modulo (ash value -8) #x100)
(modulo (ash value -16) #x100)
(modulo (ash value -24) #x100)
(modulo (ash value -32) #x100)
(modulo (ash value -40) #x100)
(modulo (ash value -48) #x100)
(modulo (ash value -56) #x100))))
(set-car! bv (car x))
(set-cdr! bv (cdr x))
x))
(define (bytevector-u32-native-set! bv index value)
(when (not (= 0 index)) (error "bytevector-u32-native-set! index not zero: " index " value: " value))
(let ((x (list
(modulo value #x100)
(modulo (ash value -8) #x100)
(modulo (ash value -16) #x100)
(modulo (ash value -24) #x100))))
(set-car! bv (car x))
(set-cdr! bv (cdr x))
x))
(define (bytevector-u16-native-set! bv index value)
(when (not (= 0 index)) (error "bytevector-u16-native-set! index not zero: " index " value: " value))
(let ((x (list
(modulo value #x100)
(modulo (ash value -8) #x100))))
(set-car! bv (car x))
(set-cdr! bv (cdr x))
x))
(define (bytevector-u8-set! bv index value)
(when (not (= 0 index)) (error "bytevector-u8-set! index not zero: " index " value: " value))
(let ((x (modulo value #x100)))
(set-car! bv x)
x))
(define (make-bytevector length)
(make-list length 0))

2663
sysa/mes-0.22/module/mescc/compile.scm Normal file
View file

File diff suppressed because it is too large Load diff

648
sysa/mes-0.22/module/mescc/i386/as.scm Normal file
View file

@ -0,0 +1,648 @@
;;; 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:
;;; define i386 assembly
;;; Code:
(define-module (mescc i386 as)
#:use-module (mes guile)
#:use-module (mescc as)
#:use-module (mescc info)
#:export (
i386:instructions
))
(define (e->x o)
(string-drop o 1))
(define (e->l o)
(string-append (string-drop-right (string-drop o 1) 1) "l"))
(define (i386:function-preamble . rest)
'(("push___%ebp")
("mov____%esp,%ebp")))
(define (i386:function-locals . rest)
`(("sub____$i32,%esp" (#:immediate ,(+ (* 4 1025) (* 20 4)))))) ; 4*1024 buf, 20 local vars
(define (i386:r->local info n)
(or n (error "invalid value: i386:r->local: " n))
(let ((r (get-r info))
(n (- 0 (* 4 n))))
`(,(if (< (abs n) #x80) `(,(string-append "mov____%" r ",0x8(%ebp)") (#:immediate1 ,n))
`(,(string-append "mov____%" r ",0x32(%ebp)") (#:immediate ,n))))))
(define (i386:value->r info v)
(let ((r (get-r info)))
`((,(string-append "mov____$i32,%" r) (#:immediate ,v)))))
(define (i386:ret . rest)
'(("leave")
("ret")))
(define (i386:r-zero? info)
(let ((r (get-r info)))
`((,(string-append "test___%" r "," "%" r)))))
(define (i386:local->r info n)
(let ((r (get-r info))
(n (- 0 (* 4 n))))
`(,(if (< (abs n) #x80) `(,(string-append "mov____0x8(%ebp),%" r) (#:immediate1 ,n))
`(,(string-append "mov____0x32(%ebp),%" r) (#:immediate ,n))))))
(define (i386:r0+r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "add____%" r1 ",%" r0)))))
(define (i386:call-label info label n)
`((call32 (#:offset ,label))
("add____$i8,%esp" (#:immediate1 ,(* n 4)))))
(define (i386:r->arg info i)
(let ((r (get-r info)))
`((,(string-append "push___%" r)))))
(define (i386:label->arg info label i)
`(("push___$i32" (#:address ,label))))
(define (i386:r-negate info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "sete___%" l))
(,(string-append "movzbl_%" l ",%" r)))))
(define (i386:r0-r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "sub____%" r1 ",%" r0)))))
(define (i386:zf->r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "sete___%" l))
(,(string-append "movzbl_%" l ",%" r)))))
(define (i386:xor-zf info)
'(("lahf")
("xor____$i8,%ah" (#:immediate1 #x40))
("sahf")))
(define (i386:r->local+n info id n)
(let ((n (+ (- 0 (* 4 id)) n))
(r (get-r info)))
`(,(if (< (abs n) #x80) `(,(string-append "mov____%" r ",0x8(%ebp)") (#:immediate1 ,n))
`(,(string-append "mov____%" r ",0x32(%ebp)") (#:immediate ,n))))))
(define (i386:r-mem-add info v)
(let ((r (get-r info)))
`(,(if (< (abs v) #x80) `(,(string-append "add____$i8,(%" r ")") (#:immediate1 ,v))
`(,(string-append "add____$i32,(%" r ")") (#:immediate ,v))))))
(define (i386:r-byte-mem-add info v)
(let ((r (get-r info)))
`((,(string-append "addb___$i8,(%" r ")") (#:immediate1 ,v)))))
(define (i386:r-word-mem-add info v)
(let ((r (get-r info)))
`((,(string-append "addw___$i8,(%" r ")") (#:immediate2 ,v)))))
(define (i386:local-ptr->r info n)
(let ((r (get-r info)))
(let ((n (- 0 (* 4 n))))
`((,(string-append "mov____%ebp,%" r))
,(if (< (abs n) #x80) `(,(string-append "add____$i8,%" r) (#:immediate1 ,n))
`(,(string-append "add____$i32,%" r) (#:immediate ,n)))))))
(define (i386:label->r info label)
(let ((r (get-r info)))
`((,(string-append "mov____$i32,%" r) (#:address ,label)))))
(define (i386:r0->r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "mov____%" r0 ",%" r1)))))
(define (i386:byte-mem->r info)
(let ((r (get-r info)))
`((,(string-append "movzbl_(%" r "),%" r)))))
(define (i386:byte-r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "movzbl_%" l ",%" r)))))
(define (i386:byte-signed-r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "movsbl_%" l ",%" r)))))
(define (i386:word-r info)
(let* ((r (get-r info))
(x (e->x r)))
`((,(string-append "movzwl_%" x ",%" r)))))
(define (i386:word-signed-r info)
(let* ((r (get-r info))
(x (e->x r)))
`((,(string-append "movswl_%" x ",%" r)))))
(define (i386:jump info label)
`(("jmp32 " (#:offset ,label))))
(define (i386:jump-z info label)
`(("je32 " (#:offset ,label))))
(define (i386:jump-nz info label)
`(("jne32 " (#:offset ,label))))
(define (i386:jump-byte-z info label)
`(("test___%al,%al")
("je32 " (#:offset ,label))))
;; signed
(define (i386:jump-g info label)
`(("jg32 " (#:offset ,label))))
(define (i386:jump-ge info label)
`(("jge32 " (#:offset ,label))))
(define (i386:jump-l info label)
`(("jl32 " (#:offset ,label))))
(define (i386:jump-le info label)
`(("jle32 " (#:offset ,label))))
;; unsigned
(define (i386:jump-a info label)
`(("ja32 " (#:offset ,label))))
(define (i386:jump-ae info label)
`(("jae32 " (#:offset ,label))))
(define (i386:jump-b info label)
`(("jb32 " (#:offset ,label))))
(define (i386:jump-be info label)
`(("jbe32 " (#:offset ,label))))
(define (i386:byte-r0->r1-mem info)
(let* ((r0 (get-r0 info))
(r1 (get-r1 info))
(l0 (e->l r0)))
`((,(string-append "mov____%" l0 ",(%" r1 ")")))))
(define (i386:label-mem->r info label)
(let ((r (get-r info)))
`((,(string-append "mov____0x32,%" r) (#:address ,label)))))
(define (i386:word-mem->r info)
(let ((r (get-r info)))
`((,(string-append "movzwl_(%" r "),%" r)))))
(define (i386:mem->r info)
(let ((r (get-r info)))
`((,(string-append "mov____(%" r "),%" r)))))
(define (i386:local-add info n v)
(let ((n (- 0 (* 4 n))))
`(,(if (and (< (abs n) #x80)
(< (abs v) #x80)) `("add____$i8,0x8(%ebp)" (#:immediate1 ,n) (#:immediate1 ,v))
`("add____$i32,0x32(%ebp)" (#:immediate ,n) (#:immediate ,v))))))
(define (i386:label-mem-add info label v)
`(,(if (< (abs v) #x80) `("add____$i8,0x32" (#:address ,label) (#:immediate1 ,v))
`("add____$i32,0x32" (#:address ,label) (#:immediate ,v)))))
(define (i386:nop info)
'(("nop")))
(define (i386:swap-r0-r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "xchg___%" r0 ",%" r1)))))
;; signed
(define (i386:g?->r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "setg___%" l))
(,(string-append "movzbl_%" l ",%" r)))))
(define (i386:ge?->r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "setge__%" l))
(,(string-append "movzbl_%" l ",%" r)))))
(define (i386:l?->r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "setl___%" l))
(,(string-append "movzbl_%" l ",%" r)))))
(define (i386:le?->r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "setle__%" l))
(,(string-append "movzbl_%" l ",%" r)))))
;; unsigned
(define (i386:a?->r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "seta___%" l))
(,(string-append "movzbl_%" l ",%" r)))))
(define (i386:ae?->r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "setae__%" l))
(,(string-append "movzbl_%" l ",%" r)))))
(define (i386:b?->r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "setb___%" l))
(,(string-append "movzbl_%" l ",%" r)))))
(define (i386:be?->r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "setbe__%" l))
(,(string-append "movzbl_%" l ",%" r)))))
(define (i386:test-r info)
(let ((r (get-r info)))
`((,(string-append "test___%" r ",%" r)))))
(define (i386:r->label info label)
(let ((r (get-r info)))
`((,(string-append "mov____%" r ",0x32") (#:address ,label)))))
(define (i386:r->byte-label info label)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "movb___%" l ",0x32") (#:address ,label)))))
(define (i386:r->word-label info label)
(let* ((r (get-r info))
(x (e->x r)))
`((,(string-append "movw___%" x ",0x32") (#:address ,label)))))
(define (i386:call-r info n)
(let ((r (get-r info)))
`((,(string-append "call___*%" r))
("add____$i8,%esp" (#:immediate1 ,(* n 4))))))
(define (i386:r0*r1 info)
(let ((allocated (.allocated info))
(r0 (get-r0 info))
(r1 (get-r1 info)))
(if (not (member "edx" allocated))
`(,@(if (equal? r0 "eax") '()
`(("push___%eax")
(,(string-append "mov____%" r0 ",%eax"))))
(,(string-append "mul____%" r1))
,@(if (equal? r0 "eax") '()
`((,(string-append "mov____%eax,%" r0))
("pop____%eax"))))
`(("push___%eax")
("push___%ebx")
("push___%edx")
(,(string-append "mov____%" r1 ",%ebx"))
(,(string-append "mov____%" r0 ",%eax"))
(,(string-append "mul____%" r1))
("pop____%edx")
("pop____%ebx")
(,(string-append "mov____%eax,%" r0))
("pop____%eax")))))
(define (i386:r0<<r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "mov____%" r1 ",%ecx"))
(,(string-append "shl____%cl,%" r0)))))
(define (i386:r0>>r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "mov____%" r1 ",%ecx"))
(,(string-append "shr____%cl,%" r0)))))
(define (i386:r0-and-r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "and____%" r1 ",%" r0)))))
(define (i386:r0/r1 info signed?)
(let ((signed? #f) ; nobody knows, -- all advice are belong to us?
(allocated (.allocated info))
(r0 (get-r0 info))
(r1 (get-r1 info)))
(if (not (member "edx" allocated))
`(,@(if (equal? r0 "eax") '()
`(("push___%eax")
(,(string-append "mov____%" r0 ",%eax"))))
,(if signed? '("cltd") '("xor____%edx,%edx"))
,(if signed? `(,(string-append "idiv___%" r1)) `(,(string-append "div___%" r1)))
,@(if (equal? r0 "eax") '()
`((,(string-append "mov____%eax,%" r0))
("pop____%eax"))))
`(("push___%eax")
("push___%ebx")
("push___%edx")
(,(string-append "mov____%" r1 ",%ebx"))
(,(string-append "mov____%" r0 ",%eax"))
,(if signed? '("cltd") '("xor____%edx,%edx"))
,(if signed? `(,(string-append "idiv___%ebx")) `(,(string-append "div___%ebx")))
("pop____%edx")
("pop____%ebx")
(,(string-append "mov____%eax,%" r0))
("pop____%eax")))))
(define (i386:r0%r1 info signed?)
(let ((signed? #f) ; nobody knows, -- all advice are belong to us?
(allocated (.allocated info))
(r0 (get-r0 info))
(r1 (get-r1 info)))
(if (not (member "edx" allocated))
`(,@(if (equal? r0 "eax") '()
`(("push___%eax")
(,(string-append "mov____%" r0 ",%eax"))))
,(if signed? '("cltd") '("xor____%edx,%edx"))
,(if signed? `(,(string-append "idiv___%" r1)) `(,(string-append "div___%" r1)))
(,(string-append "mov____%edx,%" r0)))
`(("push___%eax")
("push___%ebx")
("push___%edx")
(,(string-append "mov____%" r1 ",%ebx"))
(,(string-append "mov____%" r0 ",%eax"))
,(if signed? '("cltd") '("xor____%edx,%edx"))
,(if signed? `(,(string-append "idiv___%ebx")) `(,(string-append "div___%ebx")))
("pop____%edx")
("pop____%ebx")
(,(string-append "mov____%edx,%" r0))
("pop____%eax")))))
(define (i386:r+value info v)
(let ((r (get-r info)))
`(,(if (< (abs v) #x80) `(,(string-append "add____$i8,%" r) (#:immediate1 ,v))
`(,(string-append "add____$i32,%" r) (#:immediate ,v))))))
(define (i386:r0->r1-mem info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "mov____%" r0 ",(%" r1 ")")))))
(define (i386:byte-r0->r1-mem info)
(let* ((r0 (get-r0 info))
(r1 (get-r1 info))
(l0 (e->l r0)))
`((,(string-append "mov____%" l0 ",(%" r1 ")")))))
(define (i386:word-r0->r1-mem info)
(let* ((r0 (get-r0 info))
(r1 (get-r1 info))
(x0 (e->x r0)))
`((,(string-append "mov____%" x0 ",(%" r1 ")")))))
(define (i386:r-cmp-value info v)
(let ((r (get-r info)))
`(,(if (< (abs v) #x80) `(,(string-append "cmp____$i8,%" r) (#:immediate1 ,v))
`(,(string-append "cmp____$i32,%" r) (#:immediate ,v))))))
(define (i386:push-register info r)
`((,(string-append "push___%" r))))
(define (i386:pop-register info r)
`((,(string-append "pop____%" r))))
(define (i386:return->r info)
(let ((r (get-r info)))
(if (equal? r "eax") '()
`((,(string-append "mov____%eax,%" r))))))
(define (i386:r0-or-r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "or_____%" r1 ",%" r0)))))
(define (i386:shl-r info n)
(let ((r (get-r info)))
`((,(string-append "shl____$i8,%" r) (#:immediate1 ,n)))))
(define (i386:r+r info)
(let ((r (get-r info)))
`((,(string-append "add____%" r ",%" r)))))
(define (i386:not-r info)
(let ((r (get-r info)))
`((,(string-append "not____%" r)))))
(define (i386:r0-xor-r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "xor____%" r1 ",%" r0)))))
(define (i386:r0-mem->r1-mem info)
(let* ((registers (.registers info))
(r0 (get-r0 info))
(r1 (get-r1 info))
(r2 (car registers)))
`((,(string-append "mov____(%" r0 "),%" r2))
(,(string-append "mov____%" r2 ",(%" r1 ")")))))
(define (i386:byte-r0-mem->r1-mem info)
(let* ((registers (.registers info))
(r0 (get-r0 info))
(r1 (get-r1 info))
(r2 (car registers))
(l2 (e->l r2)))
`((,(string-append "mov____(%" r0 "),%" l2))
(,(string-append "mov____%" l2 ",(%" r1 ")")))))
(define (i386:word-r0-mem->r1-mem info)
(let* ((registers (.registers info))
(r0 (get-r0 info))
(r1 (get-r1 info))
(r2 (car registers))
(x2 (e->x r2)))
`((,(string-append "mov____(%" r0 "),%" x2))
(,(string-append "mov____%" x2 ",(%" r1 ")")))))
(define (i386:r0+value info v)
(let ((r0 (get-r0 info)))
`(,(if (< (abs v) #x80) `(,(string-append "add____$i8,%" r0) (#:immediate1 ,v))
`(,(string-append "add____$i32,%" r0) (#:immediate ,v))))))
(define (i386:value->r0 info v)
(let ((r0 (get-r0 info)))
`((,(string-append "mov____$i32,%" r0) (#:immediate ,v)))))
(define (i386:byte-r->local+n info id n)
(let* ((n (+ (- 0 (* 4 id)) n))
(r (get-r info))
(l (e->l r) ))
`(,(if (< (abs n) #x80) `(,(string-append "mov____%" l ",0x8(%ebp)") (#:immediate1 ,n))
`(,(string-append "mov____%" l ",0x32(%ebp)") (#:immediate ,n))))))
(define (i386:word-r->local+n info id n)
(let* ((n (+ (- 0 (* 4 id)) n))
(r (get-r info))
(x (e->x r)))
`(,(if (< (abs n) #x80) `(,(string-append "mov____%" x ",0x8(%ebp)") (#:immediate1 ,n))
`(,(string-append "mov____%" x ",0x32(%ebp)") (#:immediate ,n))))))
(define (i386:r-and info v)
(let ((r (get-r info)))
`((,(string-append "and____$i32,%" r) (#:immediate ,v)))))
(define (i386:push-r0 info)
(let ((r0 (get-r0 info)))
`((,(string-append "push___%" r0)))))
(define (i386:r1->r0 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "mov____%" r1 ",%" r0)))))
(define (i386:pop-r0 info)
(let ((r0 (get-r0 info)))
`((,(string-append "pop____%" r0)))))
(define (i386:swap-r-stack info)
(let ((r (get-r info)))
`((,(string-append "xchg___%" r ",(%esp)")))))
(define (i386:swap-r1-stack info)
(let ((r0 (get-r0 info)))
`((,(string-append "xchg___%" r0 ",(%esp)")))))
(define (i386:r2->r0 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info))
(allocated (.allocated info)))
(if (> (length allocated) 2)
(let ((r2 (cadddr allocated)))
`((,(string-append "mov____%" r2 ",%" r1))))
`((,(string-append "pop____%" r0))
(,(string-append "push___%" r0))))))
(define i386:instructions
`(
(a?->r . ,i386:a?->r)
(ae?->r . ,i386:ae?->r)
(b?->r . ,i386:b?->r)
(be?->r . ,i386:be?->r)
(byte-mem->r . ,i386:byte-mem->r)
(byte-r . ,i386:byte-r)
(byte-r->local+n . ,i386:byte-r->local+n)
(byte-r0->r1-mem . ,i386:byte-r0->r1-mem)
(byte-r0->r1-mem . ,i386:byte-r0->r1-mem)
(byte-r0-mem->r1-mem . ,i386:byte-r0-mem->r1-mem)
(byte-signed-r . ,i386:byte-signed-r)
(call-label . ,i386:call-label)
(call-r . ,i386:call-r)
(function-locals . ,i386:function-locals)
(function-preamble . ,i386:function-preamble)
(g?->r . ,i386:g?->r)
(ge?->r . ,i386:ge?->r)
(jump . ,i386:jump)
(jump-a . ,i386:jump-a)
(jump-ae . ,i386:jump-ae)
(jump-b . ,i386:jump-b)
(jump-be . ,i386:jump-be)
(jump-byte-z . ,i386:jump-byte-z)
(jump-g . , i386:jump-g)
(jump-ge . , i386:jump-ge)
(jump-l . ,i386:jump-l)
(jump-le . ,i386:jump-le)
(jump-nz . ,i386:jump-nz)
(jump-z . ,i386:jump-z)
(l?->r . ,i386:l?->r)
(label->arg . ,i386:label->arg)
(label->r . ,i386:label->r)
(label-mem->r . ,i386:label-mem->r)
(label-mem-add . ,i386:label-mem-add)
(le?->r . ,i386:le?->r)
(local->r . ,i386:local->r)
(local-add . ,i386:local-add)
(local-ptr->r . ,i386:local-ptr->r)
(long-r0->r1-mem . ,i386:r0->r1-mem)
(long-r0-mem->r1-mem . ,i386:r0-mem->r1-mem)
(mem->r . ,i386:mem->r)
(nop . ,i386:nop)
(not-r . ,i386:not-r)
(pop-r0 . ,i386:pop-r0)
(pop-register . ,i386:pop-register)
(push-r0 . ,i386:push-r0)
(push-register . ,i386:push-register)
(r+r . ,i386:r+r)
(r+value . ,i386:r+value)
(r->arg . ,i386:r->arg)
(r->byte-label . ,i386:r->byte-label)
(r->label . ,i386:r->label)
(r->local . ,i386:r->local)
(r->local+n . ,i386:r->local+n)
(r->word-label . ,i386:r->word-label)
(r-and . ,i386:r-and)
(r-byte-mem-add . ,i386:r-byte-mem-add)
(r-cmp-value . ,i386:r-cmp-value)
(r-mem-add . ,i386:r-mem-add)
(r-negate . ,i386:r-negate)
(r-word-mem-add . ,i386:r-word-mem-add)
(r-zero? . ,i386:r-zero?)
(r0%r1 . ,i386:r0%r1)
(r0*r1 . ,i386:r0*r1)
(r0+r1 . ,i386:r0+r1)
(r0+value . ,i386:r0+value)
(r0->r1 . ,i386:r0->r1)
(r0->r1-mem . ,i386:r0->r1-mem)
(r0-and-r1 . ,i386:r0-and-r1)
(r0-mem->r1-mem . ,i386:r0-mem->r1-mem)
(r0-or-r1 . ,i386:r0-or-r1)
(r0-r1 . ,i386:r0-r1)
(r0-xor-r1 . ,i386:r0-xor-r1)
(r0/r1 . ,i386:r0/r1)
(r0<<r1 . ,i386:r0<<r1)
(r0>>r1 . ,i386:r0>>r1)
(r1->r0 . ,i386:r1->r0)
(r2->r0 . ,i386:r2->r0)
(ret . ,i386:ret)
(return->r . ,i386:return->r)
(shl-r . ,i386:shl-r)
(swap-r-stack . ,i386:swap-r-stack)
(swap-r0-r1 . ,i386:swap-r0-r1)
(swap-r1-stack . ,i386:swap-r1-stack)
(test-r . ,i386:test-r)
(value->r . ,i386:value->r)
(value->r0 . ,i386:value->r0)
(word-mem->r . ,i386:word-mem->r)
(word-r . ,i386:word-r)
(word-r->local+n . ,i386:word-r->local+n)
(word-r0->r1-mem . ,i386:word-r0->r1-mem)
(word-r0-mem->r1-mem . ,i386:word-r0-mem->r1-mem)
(word-signed-r . ,i386:word-signed-r)
(xor-zf . ,i386:xor-zf)
(zf->r . ,i386:zf->r)
))

61
sysa/mes-0.22/module/mescc/i386/info.scm Normal file
View file

@ -0,0 +1,61 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 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:
;;; Initialize MesCC as i386/x86 compiler
;;; Code:
(define-module (mescc i386 info)
#:use-module (mescc info)
#:use-module (mescc i386 as)
#:export (x86-info))
(define (x86-info)
(make <info> #:types i386:type-alist #:registers i386:registers #:instructions i386:instructions))
(define i386:registers '("eax" "ebx" "ecx" "edx" "esi" "edi"))
(define i386:type-alist
`(("char" . ,(make-type 'signed 1 #f))
("short" . ,(make-type 'signed 2 #f))
("int" . ,(make-type 'signed 4 #f))
("long" . ,(make-type 'signed 4 #f))
("default" . ,(make-type 'signed 4 #f))
("*" . ,(make-type 'unsigned 4 #f))
("long long" . ,(make-type 'signed 4 #f))
("long long int" . ,(make-type 'signed 4 #f))
("void" . ,(make-type 'void 1 #f))
("unsigned char" . ,(make-type 'unsigned 1 #f))
("unsigned short" . ,(make-type 'unsigned 2 #f))
("unsigned" . ,(make-type 'unsigned 4 #f))
("unsigned int" . ,(make-type 'unsigned 4 #f))
("unsigned long" . ,(make-type 'unsigned 4 #f))
("unsigned long long" . ,(make-type 'unsigned 4 #f))
("unsigned long long int" . ,(make-type 'unsigned 4 #f))
("float" . ,(make-type 'float 4 #f))
("double" . ,(make-type 'float 4 #f))
("long double" . ,(make-type 'float 4 #f))
("short int" . ,(make-type 'signed 2 #f))
("unsigned short int" . ,(make-type 'unsigned 2 #f))
("long int" . ,(make-type 'signed 4 #f))
("unsigned long int" . ,(make-type 'unsigned 4 #f))))

305
sysa/mes-0.22/module/mescc/info.scm Normal file
View file

@ -0,0 +1,305 @@
;;; 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:
;;; info.scm defines [Guile] record data types for MesCC
;;; Code:
(define-module (mescc info)
#:use-module (ice-9 optargs)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:export (<info>
make
clone
make-<info>
info?
.types
.constants
.functions
.globals
.locals
.function
.statics
.text
.post
.break
.continue
.allocated
.pushed
.registers
.instructions
<type>
make-type
type?
type:type
type:size
type:pointer
type:description
<c-array>
make-c-array
c-array?
c-array:type
c-array:count
<pointer>
make-pointer
pointer?
pointer:type
pointer:rank
<bit-field>
make-bit-field
bit-field?
bit-field:type
bit-field:bit
bit-field:bits
<var>
var:name
var:type
var:pointer
var:c-array
<global>
make-global
global?
global:name
global:type
global:pointer
global:c-array
global:var
global:value
global:storage
global:function
global->string
<local>
make-local
local?
local:type
local:pointer
local:c-array
local:var
local:id
<function>
make-function
function?
function:name
function:type
function:text
function->string
->type
->rank
rank--
rank++
rank+=
structured-type?))
(define-immutable-record-type <info>
(make-<info> types constants functions globals locals statics function text post break continue allocated pushed registers instructions)
info?
(types .types)
(constants .constants)
(functions .functions)
(globals .globals)
(locals .locals)
(statics .statics)
(function .function)
(text .text)
(post .post)
(break .break)
(continue .continue)
(allocated .allocated)
(pushed .pushed)
(registers .registers)
(instructions .instructions))
(define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (locals '()) (statics '()) (function #f) (text '()) (post '()) (break '()) (continue '()) (allocated '()) (pushed 0) (registers '()) (instructions '()))
(cond ((eq? o <info>)
(make-<info> types constants functions globals locals statics function text post break continue allocated pushed registers instructions))))
(define (clone o . rest)
(cond ((info? o)
(let ((types (.types o))
(constants (.constants o))
(functions (.functions o))
(globals (.globals o))
(locals (.locals o))
(statics (.statics o))
(function (.function o))
(text (.text o))
(post (.post o))
(break (.break o))
(continue (.continue o))
(allocated (.allocated o))
(pushed (.pushed o))
(registers (.registers o))
(instructions (.instructions o)))
(let-keywords rest
#f
((types types)
(constants constants)
(functions functions)
(globals globals)
(locals locals)
(statics statics)
(function function)
(text text)
(post post)
(break break)
(continue continue)
(allocated allocated)
(pushed pushed)
(registers registers)
(instructions instructions))
(make <info> #:types types #:constants constants #:functions functions #:globals globals #:locals locals #:statics statics #:function function #:text text #:post post #:break break #:continue continue #:allocated allocated #:pushed pushed #:registers registers #:instructions instructions))))))
;; ("int" . ,(make-type 'builtin 4 #f 0 #f))
;; (make-type 'enum 4 0 fields)
;; (make-type 'struct (apply + (map field:size fields)) 0 fields)
(define-immutable-record-type <type>
(make-type type size description)
type?
(type type:type)
(size type:size)
(description type:description))
(define-immutable-record-type <c-array>
(make-c-array type count)
c-array?
(type c-array:type)
(count c-array:count))
(define-immutable-record-type <pointer>
(make-pointer type rank)
pointer?
(type pointer:type)
(rank pointer:rank))
(define-immutable-record-type <bit-field>
(make-bit-field type bit bits)
bit-field?
(type bit-field:type)
(bit bit-field:bit)
(bits bit-field:bits))
(define-immutable-record-type <var>
(make-var name type function id value)
var?
(name var:name)
(type var:type) ; <type>
(function var:function)
(id var:id)
(value var:value))
(define-immutable-record-type <global>
(make-global- name type var value storage function)
global?
(name global:name)
(type global:type)
(var global:var) ; <var>
(value global:value)
(storage global:storage)
(function global:function))
(define (make-global name type value storage function)
(make-global- name type (make-var name type function #f value) value storage function))
(define (global->string o)
(or (and=> (global:function o) (cut string-append <> "-" (global:name o)))
(global:name o)))
(define-immutable-record-type <local>
(make-local- type var id)
local?
(type local:type)
(var local:var) ; <var>
(id local:id))
(define (make-local name type id)
(make-local- type (make-var name type #f id #f) id))
(define-immutable-record-type <function>
(make-function name type text)
function?
(name function:name)
(type function:type)
(text function:text))
(define (function->string o)
(function:name o))
(define (structured-type? o)
(cond ((type? o) (memq (type:type o) '(struct union)))
((global? o) ((compose structured-type? global:type) o))
((local? o) ((compose structured-type? local:type) o))
((and (pair? o) (eq? (car o) 'tag))) ;; FIXME: enum?
(else #f)))
(define (->type o)
(cond ((type? o) o)
((bit-field? o) o)
((pointer? o) ((compose ->type pointer:type) o))
((c-array? o) ((compose ->type c-array:type) o))
((and (pair? o) (eq? (car o) 'tag)) o)
;; FIXME
(#t
(format (current-error-port) "->type--: not a <type>: ~s\n" o)
(make-type 'builtin 4 #f))
(else (error "->type: not a <type>:" o))))
(define (->rank o)
(cond ((type? o) 0)
((pointer? o) (pointer:rank o))
((c-array? o) (1+ ((compose ->rank c-array:type) o)))
((local? o) ((compose ->rank local:type) o))
((global? o) ((compose ->rank global:type) o))
((bit-field? o) 0)
;; FIXME
(#t
(format (current-error-port) "->rank: not a type: ~s\n" o)
0)
(else (error "->rank: not a <type>:" o))))
(define (rank-- o)
(cond ((and (pointer? o) (= (pointer:rank o) 1)) (pointer:type o))
((pointer? o) (set-field o (pointer:rank) (1- (pointer:rank o))))
((c-array? o) (c-array:type o))
;; FIXME
(#t (format (current-error-port) "rank--: not a pointer: ~s\n" o)
o)
(else (error "rank--: not a pointer" o))))
(define (rank+= o i)
(cond ((pointer? o) (set-field o (pointer:rank) (+ i (pointer:rank o))))
(else (make-pointer o i))))
(define (rank++ o)
(rank+= o 1))

368
sysa/mes-0.22/module/mescc/mescc.scm Normal file
View file

@ -0,0 +1,368 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018,2019 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/>.
(define-module (mescc mescc)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 getopt-long)
#:use-module (mes misc)
#:use-module (mescc i386 info)
#:use-module (mescc x86_64 info)
#:use-module (mescc preprocess)
#:use-module (mescc compile)
#:use-module (mescc M1)
#:export (count-opt
mescc:preprocess
mescc:get-host
mescc:compile
mescc:assemble
mescc:link
multi-opt))
(define GUILE-with-output-to-file with-output-to-file)
(define (with-output-to-file file-name thunk)
(if (equal? file-name "-") (thunk)
(GUILE-with-output-to-file file-name thunk)))
(define (mescc:preprocess options)
(let* ((pretty-print/write (string->symbol (option-ref options 'write (if guile? "pretty-print" "write"))))
(pretty-print/write (if (eq? pretty-print/write 'pretty-print) pretty-print write))
(files (option-ref options '() '("a.c")))
(input-file-name (car files))
(input-base (basename input-file-name))
(ast-file-name (cond ((and (option-ref options 'preprocess #f)
(option-ref options 'output #f)))
(else (replace-suffix input-base ".E"))))
(dir (dirname input-file-name))
(defines (reverse (filter-map (multi-opt 'define) options)))
(includes (reverse (filter-map (multi-opt 'include) options)))
(includes (cons (option-ref options 'includedir #f) includes))
(includes (cons dir includes))
(prefix (option-ref options 'prefix ""))
(machine (option-ref options 'machine "32"))
(arch (arch-get options))
(defines (cons (arch-get-define options) defines))
(verbose? (count-opt options 'verbose)))
(with-output-to-file ast-file-name
(lambda _ (for-each (cut c->ast prefix defines includes arch pretty-print/write verbose? <>) files)))))
(define (c->ast prefix defines includes arch write verbose? file-name)
(with-input-from-file file-name
(cut write (c99-input->ast #:prefix prefix #:defines defines #:includes includes #:arch arch #:verbose? verbose?))))
(define (mescc:compile options)
(let* ((files (option-ref options '() '("a.c")))
(input-file-name (car files))
(input-base (basename input-file-name))
(M1-file-name (cond ((and (option-ref options 'compile #f)
(option-ref options 'output #f)))
((string-suffix? ".S" input-file-name) input-file-name)
(else (replace-suffix input-base ".s"))))
(infos (map (cut file->info options <>) files))
(verbose? (count-opt options 'verbose))
(align? (option-ref options 'align #f)))
(when verbose?
(stderr "dumping: ~a\n" M1-file-name))
(with-output-to-file M1-file-name
(cut infos->M1 M1-file-name infos #:align? align? #:verbose? verbose?))
M1-file-name))
(define (file->info options file-name)
(cond ((.c? file-name) (c->info options file-name))
((.E? file-name) (E->info options file-name))))
(define (c->info options file-name)
(let* ((dir (dirname file-name))
(defines (reverse (filter-map (multi-opt 'define) options)))
(includes (reverse (filter-map (multi-opt 'include) options)))
(includes (cons (option-ref options 'includedir #f) includes))
(includes (cons dir includes))
(prefix (option-ref options 'prefix ""))
(defines (cons (arch-get-define options) defines))
(arch (arch-get options))
(verbose? (count-opt options 'verbose)))
(with-input-from-file file-name
(cut c99-input->info (arch-get-info options) #:prefix prefix #:defines defines #:includes includes #:arch arch #:verbose? verbose?))))
(define (E->info options file-name)
(let ((ast (with-input-from-file file-name read))
(verbose? (count-opt options 'verbose)))
(c99-ast->info (arch-get-info options) ast #:verbose? verbose?)))
(define (mescc:assemble options)
(let* ((files (option-ref options '() '("a.c")))
(input-file-name (car files))
(input-base (basename input-file-name))
(hex2-file-name (cond ((and (option-ref options 'assemble #f)
(option-ref options 'output #f)))
(else (replace-suffix input-base ".o"))))
(s-files (filter .s? files))
(hex2-files M1->hex2 ) ;; FIXME
(source-files (filter (disjoin .c? .E?) files))
(infos (map (cut file->info options <>) source-files)))
(if (and (pair? s-files) (pair? infos))
(error "mixing source and object not supported:" source-files s-files))
(when (pair? s-files)
(M1->hex2 options s-files))
(when (pair? infos)
(infos->hex2 options hex2-file-name infos))
hex2-file-name))
(define (mescc:link options)
(let* ((files (option-ref options '() '("a.c")))
(source-files (filter (disjoin .c? .E?) files))
(s-files (filter .s? files))
(o-files (filter .o? files))
(input-file-name (car files))
(hex2-file-name (if (or (string-suffix? ".hex2" input-file-name)
(string-suffix? ".o" input-file-name)) input-file-name
(replace-suffix input-file-name ".o")))
(infos (map (cut file->info options <>) source-files))
(s-files (filter .s? files))
(hex2-files (filter .o? files))
(hex2-files (if (null? s-files) hex2-files
(append hex2-files (list (M1->hex2 options s-files)))))
(hex2-files (if (null? infos) hex2-files
(append hex2-files
(list (infos->hex2 options hex2-file-name infos)))))
(default-libraries (if (or (option-ref options 'nodefaultlibs #f)
(option-ref options 'nostdlib #f)) '()
'("c")))
(libraries (filter-map (multi-opt 'library) options))
(libraries (delete-duplicates (append libraries default-libraries)))
(hex2-libraries (map (cut find-library options ".a" <>) libraries))
(hex2-files (append hex2-files hex2-libraries))
(s-files (append s-files (map (cut find-library options ".s" <>) libraries)))
(debug-info? (option-ref options 'debug-info #f))
(s-files (if (string-suffix? ".S" input-file-name) s-files
(cons (replace-suffix input-file-name ".s") s-files)))
(elf-footer (and debug-info?
(or (M1->blood-elf options s-files)
(exit 1)))))
(or (hex2->elf options hex2-files #:elf-footer elf-footer)
(exit 1))))
(define (infos->hex2 options hex2-file-name infos)
(let* ((input-file-name (car (option-ref options '() '("a.c"))))
(M1-file-name (replace-suffix hex2-file-name ".s"))
(options (acons 'compile #t options)) ; ugh
(options (acons 'output hex2-file-name options))
(verbose? (count-opt options 'verbose))
(align? (option-ref options 'align #f)))
(when verbose?
(stderr "dumping: ~a\n" M1-file-name))
(with-output-to-file M1-file-name
(cut infos->M1 M1-file-name infos #:align? align?))
(or (M1->hex2 options (list M1-file-name))
(exit 1))))
(define (M1->hex2 options M1-files)
(let* ((input-file-name (car (option-ref options '() '("a.c"))))
(input-base (basename input-file-name))
(M1-file-name (car M1-files))
(hex2-file-name (cond ((and (option-ref options 'assemble #f)
(option-ref options 'output #f)))
((option-ref options 'assemble #f)
(replace-suffix input-base ".o"))
(else (replace-suffix M1-file-name ".o"))))
(verbose? (count-opt options 'verbose))
(M1 (or (getenv "M1") "M1"))
(command `(,M1
"--LittleEndian"
,@(arch-get-architecture options)
"-f" ,(arch-find options (arch-get-m1-macros options))
,@(append-map (cut list "-f" <>) M1-files)
"-o" ,hex2-file-name)))
(when (and verbose? (> verbose? 1))
(stderr "~a\n" (string-join command)))
(and (zero? (apply assert-system* command))
hex2-file-name)))
(define* (hex2->elf options hex2-files #:key elf-footer)
(let* ((input-file-name (car (option-ref options '() '("a.c"))))
(elf-file-name (cond ((option-ref options 'output #f))
(else "a.out")))
(verbose? (count-opt options 'verbose))
(hex2 (or (getenv "HEX2") "hex2"))
(base-address (option-ref options 'base-address "0x1000000"))
(machine (arch-get-machine options))
(elf-footer
(or elf-footer
(kernel-find
options
(string-append "elf" machine "-footer-single-main.hex2"))))
(start-files (if (or (option-ref options 'nostartfiles #f)
(option-ref options 'nostdlib #f)) '()
`("-f" ,(arch-find options "crt1.o"))))
(command `(,hex2
"--LittleEndian"
,@(arch-get-architecture options)
"--BaseAddress" ,base-address
"-f" ,(kernel-find
options
(string-append "elf" machine "-header.hex2"))
,@start-files
,@(append-map (cut list "-f" <>) hex2-files)
"-f" ,elf-footer
"--exec_enable"
"-o" ,elf-file-name)))
(when (and verbose? (> verbose? 1))
(stderr "~a\n" (string-join command)))
(and (zero? (apply assert-system* command))
elf-file-name)))
(define (M1->blood-elf options M1-files)
(let* ((M1-file-name (car M1-files))
(M1-blood-elf-footer (string-append M1-file-name ".blood-elf"))
(hex2-file-name (replace-suffix M1-file-name ".o"))
(blood-elf-footer (string-append hex2-file-name ".blood-elf"))
(verbose? (count-opt options 'verbose))
(blood-elf (or (getenv "BLOOD_ELF") "blood-elf"))
(command `(,blood-elf
"-f" ,(arch-find options (arch-get-m1-macros options))
,@(append-map (cut list "-f" <>) M1-files)
"-o" ,M1-blood-elf-footer)))
(when (and verbose? (> verbose? 1))
(format (current-error-port) "~a\n" (string-join command)))
(and (zero? (apply assert-system* command))
(let* ((options (acons 'compile #t options)) ; ugh
(options (acons 'output blood-elf-footer options)))
(M1->hex2 options (list M1-blood-elf-footer))))))
(define (replace-suffix file-name suffix)
(let* ((parts (string-split file-name #\.))
(base (if (pair? (cdr parts)) (drop-right parts 1)))
(old-suffix (last parts))
(program-prefix (cond ((string-prefix? "arm-mes-" old-suffix) ".arm-mes-")
((string-prefix? "x86-mes-" old-suffix) ".x86-mes-")
((string-prefix? "x86_64-mes-" old-suffix) ".x86_64-mes-")
(else "."))))
(if (string-null? suffix)
(if (string-null? program-prefix) (string-join base ".")
(string-append (string-drop program-prefix 1) (string-join base ".")))
(string-append (string-join base ".") program-prefix (string-drop suffix 1)))))
(define (find-library options ext o)
(arch-find options (string-append "lib" o ext)))
(define* (arch-find options file-name #:key kernel)
(let* ((srcdest (or (getenv "srcdest") ""))
(srcdir-lib (string-append srcdest "lib"))
(arch (string-append (arch-get options) "-mes"))
(path (cons* "."
srcdir-lib
(option-ref options 'libdir "lib")
(filter-map (multi-opt 'library-dir) options)))
(arch-file-name (string-append arch "/" file-name))
(arch-file-name (if kernel (string-append kernel "/" arch-file-name)
arch-file-name))
(verbose? (count-opt options 'verbose)))
(let ((file (search-path path arch-file-name)))
(when (and verbose? (> verbose? 1))
(stderr "arch-find=~s\n" arch-file-name)
(stderr " path=~s\n" path)
(stderr " => ~s\n" file))
(or file
(error (format #f "mescc: file not found: ~s" arch-file-name))))))
(define (kernel-find options file-name)
(let ((kernel (option-ref options 'kernel "linux")))
(or (arch-find options file-name #:kernel kernel)
(arch-find options file-name))))
(define (assert-system* . args)
(let ((status (apply system* args)))
(when (not (zero? status))
(stderr "mescc: failed: ~a\n" (string-join args))
(exit (status:exit-val status)))
status))
(define (arch-get options)
(let* ((machine (option-ref options 'machine #f))
(arch (option-ref options 'arch #f)))
(if machine (cond ((member arch '("x86" "x86_64")) (cond ((equal? machine "32") "x86")
((equal? machine "64") "x86_64")))
((equal? arch "arm") (cond ((equal? machine "32") "arm"))))
arch)))
(define (mescc:get-host options)
(let ((cpu (arch-get options))
(kernel (option-ref options 'kernel "linux")))
(string-join (list cpu kernel "mes") "-")))
(define (arch-get-info options)
(let ((arch (arch-get options)))
(cond ((equal? arch "arm") (armv4-info))
((equal? arch "x86") (x86-info))
((equal? arch "x86_64") (x86_64-info)))))
(define (arch-get-define options)
(let ((arch (arch-get options)))
(cond ((equal? arch "arm") "__arm__=1")
((equal? arch "x86") "__i386__=1")
((equal? arch "x86_64") "__x86_64__=1"))))
(define (arch-get-machine options)
(let* ((machine (option-ref options 'machine #f))
(arch (option-ref options 'arch #f)))
(or machine
(if (member arch '("x86_64")) "64"
"32"))))
(define (arch-get-m1-macros options)
(let ((arch (arch-get options)))
(cond ((equal? arch "arm") "arm.M1")
((equal? arch "x86") "x86.M1")
((equal? arch "x86_64") "x86_64.M1"))))
(define (arch-get-architecture options)
(let* ((arch (arch-get options))
(numbered-arch? (option-ref options 'numbered-arch? #f))
(flag (if numbered-arch? "--Architecture" "--architecture")))
(list flag
(cond ((equal? arch "arm") (if numbered-arch? "40" "armv7l"))
((equal? arch "x86") (if numbered-arch? "1" "x86"))
((equal? arch "x86_64") (if numbered-arch? "2" "amd64"))))))
(define (multi-opt option-name) (lambda (o) (and (eq? (car o) option-name) (cdr o))))
(define (count-opt options option-name)
(let ((lst (filter-map (multi-opt option-name) options)))
(and (pair? lst) (length lst))))
(define (.c? o) (or (string-suffix? ".c" o)
(string-suffix? ".M2" o)))
(define (.E? o) (or (string-suffix? ".E" o)
(string-suffix? ".mes-E" o)
(string-suffix? ".arm-mes-E" o)
(string-suffix? ".x86-mes-E" o)
(string-suffix? ".x86_64-mes-E" o)))
(define (.s? o) (or (string-suffix? ".s" o)
(string-suffix? ".S" o)
(string-suffix? ".mes-S" o)
(string-suffix? ".arm-mes-S" o)
(string-suffix? ".x86-mes-S" o)
(string-suffix? ".x86_64-mes-S" o)
(string-suffix? ".M1" o)))
(define (.o? o) (or (string-suffix? ".o" o)
(string-suffix? ".mes-o" o)
(string-suffix? ".arm-mes-o" o)
(string-suffix? ".x86-mes-o" o)
(string-suffix? ".x86_64-mes-o" o)
(string-suffix? ".hex2" o)))

144
sysa/mes-0.22/module/mescc/preprocess.scm Normal file
View file

@ -0,0 +1,144 @@
;;; 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:
;;; Code:
(define-module (mescc preprocess)
#:use-module (ice-9 optargs)
#:use-module (system base pmatch)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (nyacc lang c99 parser)
#:use-module (nyacc lang c99 parser)
#:use-module (nyacc version)
#:use-module (mes guile)
#:export (c99-input->ast))
(define mes-or-reproducible? #t)
(when (getenv "MESC_DEBUG")
(format (current-error-port) "*nyacc-version*=~a\n" *nyacc-version*))
;; list of which rules you want progress reported
(define need-progress
(or (assoc-ref
'(("0.85.3" (1 2 3))
("0.86.0" (1 2 3)))
*nyacc-version*)
'((1 2 3))))
(define (progress o)
(when (and o (getenv "NYACC_DEBUG"))
(display " :" (current-error-port))
(display o (current-error-port))
(display "\n" (current-error-port))))
(define (insert-progress-monitors act-v len-v)
(let ((n (vector-length act-v)))
(let loop ((ix 0))
(when (< ix n)
(if (memq ix need-progress)
(vector-set!
act-v ix
(lambda args
(progress (list-ref args (1- (vector-ref len-v ix))))
(apply (vector-ref act-v ix) args))))
(loop (1+ ix))))))
(cond-expand
(guile
(insert-progress-monitors (@@ (nyacc lang c99 parser) c99-act-v)
(@@ (nyacc lang c99 parser) c99-len-v)))
(mes
(insert-progress-monitors c99-act-v c99-len-v)))
(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 mes? (pair? (current-module)))
(define* (c99-input->full-ast #:key (prefix "") (defines '()) (includes '()) (arch "") verbose?)
(let* ((sys-include (if (equal? prefix "") "include"
(string-append prefix "/include")))
(kernel "linux")
(kernel-include (string-append sys-include "/" kernel "/" arch))
(includes (append
includes
(cons* kernel-include
sys-include
(append (or (and=> (getenv "CPATH")
(cut string-split <> #\:)) '())
(or (and=> (getenv "C_INCLUDE_PATH")
(cut string-split <> #\:)) '())))))
(defines `(
"NULL=0"
"__linux__=1"
"_POSIX_SOURCE=0"
"SYSTEM_LIBC=0"
"__STDC__=1"
"__MESC__=1"
,(if mes-or-reproducible? "__MESC_MES__=1" "__MESC_MES__=0")
,@defines)))
(when (and verbose? (> verbose? 1))
(stderr "includes: ~s\n" includes)
(stderr "defines: ~s\n" defines))
(parse-c99
#:inc-dirs includes
#:cpp-defs defines
#:mode 'code)))
(define* (c99-input->ast #:key (prefix "") (defines '()) (includes '()) (arch "") verbose?)
(when verbose?
(stderr "parsing: input\n"))
((compose ast-strip-const ast-strip-comment) (c99-input->full-ast #:prefix prefix #:defines defines #:includes includes #:arch arch #:verbose? verbose?)))
(define (ast-strip-comment o)
(pmatch o
((@ (comment . ,comment)) #f) ; Nyacc 0.90.2/0.93.0?
((comment . ,comment) #f)
(((comment . ,comment) . ,t) (filter-map ast-strip-comment t))
(((comment . ,comment) . ,cdr) cdr)
((,car . (comment . ,comment)) car)
((,h . ,t) (if (list? o) (filter-map ast-strip-comment o)
(cons (ast-strip-comment h) (ast-strip-comment t))))
(_ o)))
(define (ast-strip-const o)
(pmatch o
((type-qual ,qual) (if (equal? qual "const") #f o))
((pointer (type-qual-list (type-qual ,qual)) . ,rest)
(if (equal? qual "const") `(pointer ,@rest) o))
((decl-spec-list (type-qual ,qual))
(if (equal? qual "const") #f
`(decl-spec-list (type-qual ,qual))))
((decl-spec-list (type-qual ,qual) . ,rest)
(if (equal? qual "const") `(decl-spec-list ,@rest)
`(decl-spec-list (type-qual ,qual) ,@(map ast-strip-const rest))))
((decl-spec-list (type-qual-list (type-qual ,qual)) . ,rest)
(if (equal? qual "const") `(decl-spec-list ,@rest)
`(decl-spec-list (type-qual-list (type-qual ,qual)) ,@(map ast-strip-const rest))))
((,h . ,t) (if (list? o) (filter-map ast-strip-const o)
(cons (ast-strip-const h) (ast-strip-const t))))
(_ o)))

782
sysa/mes-0.22/module/mescc/x86_64/as.scm Normal file
View file

@ -0,0 +1,782 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 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:
;;; Define x86_64 M1 assembly
;;; Code:
(define-module (mescc x86_64 as)
#:use-module (mes guile)
#:use-module (mescc as)
#:use-module (mescc info)
#:use-module (mescc x86_64 info)
#:export (
x86_64:instructions
))
(define (r->e o)
(string-append "e" (string-drop o 1)))
(define (r->x o)
(string-drop o 1))
(define (r->l o)
(assoc-ref
'(("rax" . "al")
("rdi" . "dil")
("rsi" . "sil")
("rdx" . "dl")
("rcx" . "cl")
("r8" . "r8b")
("r9" . "r9b"))
o))
;; AMD
(define (x86_64:function-preamble info . rest)
`(("push___%rbp")
("mov____%rsp,%rbp")
("sub____$i32,%rbp" "%0x80")
,@(list-head
'(("mov____%rdi,0x8(%rbp)" "!0x10")
("mov____%rsi,0x8(%rbp)" "!0x18")
("mov____%rdx,0x8(%rbp)" "!0x20")
("mov____%rcx,0x8(%rbp)" "!0x28")
("mov____%r8,0x8(%rbp)" "!0x30")
("mov____%r9,0x8(%rbp)" "!0x38"))
(length (car rest)))))
;; traditional
(define (x86_64:function-preamble info . rest)
`(("push___%rbp")
("mov____%rsp,%rbp")))
(define (x86_64:function-locals . rest)
`(
;; FIXME: how on x86_64?
("sub____$i32,%rsp" (#:immediate ,(+ (* 4 1025) (* 20 8))))
)) ; 4*1024 buf, 20 local vars
(define (x86_64:r->local info n)
(let ((r (get-r info))
(n (- 0 (* 8 n))))
`(,(if (< (abs n) #x80)
`(,(string-append "mov____%" r ",0x8(%rbp)") (#:immediate1 ,n))
`(,(string-append "mov____%" r ",0x32(%rbp)") (#:immediate ,n))))))
(define (x86_64:value->r info v)
(or v (error "invalid value: x86_64:value->r: " v))
(let ((r (get-r info)))
(if (and (>= v 0)
(< v #xffffffff))
`((,(string-append "mov____$i32,%" r) (#:immediate ,v)))
`((,(string-append "mov____$i64,%" r) (#:immediate8 ,v))))))
;; AMD
(define (x86_64:ret . rest)
'(("add____$i32,%rbp" "%0x80")
("mov____%rbp,%rsp")
("pop____%rbp")
("ret")))
;; traditional
(define (x86_64:ret . rest)
'(("mov____%rbp,%rsp")
("pop____%rbp")
("ret")))
(define (x86_64:r-zero? info)
(let ((r (car (if (pair? (.allocated info)) (.allocated info) (.registers info)))))
`((,(string-append "test___%" r "," "%" r)))))
(define (x86_64:local->r info n)
(let ((r (car (if (pair? (.allocated info)) (.allocated info) (.registers info))))
(n (- 0 (* 8 n))))
`(,(if (< (abs n) #x80) `(,(string-append "mov____0x8(%rbp),%" r) (#:immediate1 ,n))
`(,(string-append "mov____0x32(%rbp),%" r) (#:immediate ,n))))))
(define (x86_64:call-label info label n)
`((call32 (#:offset ,label))
("add____$i8,%rsp" (#:immediate1 ,(* n 8))) ;; NOT AMD
))
(define x86_64:calling-convention-registers '("rax" "rdi" "rsi" "rdx" "rcx" "r8" "r9"))
;; AMD
(define (x86_64:r->arg info i)
(let ((r (get-r info))
(r1 (list-ref x86_64:calling-convention-registers (1+ i))))
`((,(string-append "mov____%" r ",%" r1))))) ; debug fail-safe check
(define (x86_64:label->arg info label i)
(let ((r0 (list-ref x86_64:registers (1+ i))))
(if (< label #x80000000)
`((,(string-append "mov____$i32,%" r0) (#:address ,label)))
`((,(string-append "mov____$i64,%" r0) (#:address8 ,label))))))
;; traditional
(define (x86_64:r->arg info i)
(let ((r (get-r info)))
`((,(string-append "push___%" r)))))
(define (x86_64:label->arg info label i)
`(("push___$i32" (#:address ,label))))
;; FIXME?
;; (define (x86_64:label->arg info label i)
;; `((,(string-append "mov____$i64,%r15") (#:address8 ,label))
;; ("push___%r15" (#:address ,label))))
(define (x86_64:r0+r1 info)
(let ((r1 (get-r1 info))
(r0 (get-r0 info)))
`((,(string-append "add____%" r1 ",%" r0)))))
(define (x86_64:r-negate info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "sete___%" l))
(,(string-append "movzbq_%" l ",%" r)))))
(define (x86_64:r0-r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "sub____%" r1 ",%" r0)))))
(define (x86_64:zf->r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "sete___%" l))
(,(string-append "movzbq_%" l ",%" r)))))
(define (x86_64:xor-zf info)
'(("lahf")
("xor____$i8,%ah" (#:immediate1 #x40))
("sahf")))
(define (x86_64:r->local+n info id n)
(let ((n (+ (- 0 (* 8 id)) n))
(r (get-r info)))
`(,(if (< (abs n) #x80) `(,(string-append "mov____%" r ",0x8(%rbp)") (#:immediate1 ,n))
`(,(string-append "mov____%" r ",0x32(%rbp)") (#:immediate ,n))))))
(define (x86_64:r-mem-add info v)
(let ((r (get-r info)))
`(,(if (< (abs v) #x80) `(,(string-append "add____$i8,(%" r ")") (#:immediate1 ,v))
`(,(string-append "add____$i32,(%" r ")") (#:immediate ,v)))))) ;; FIXME 64bit
(define (x86_64:r-byte-mem-add info v)
(let ((r (get-r info)))
`((,(string-append "addb___$i8,(%" r ")") (#:immediate1 ,v)))))
(define (x86_64:r-word-mem-add info v)
(let ((r (get-r info)))
`((,(string-append "addw___$i8,(%" r ")") (#:immediate2 ,v)))))
(define (x86_64:local-ptr->r info n)
(let ((r (get-r info)))
(let ((n (- 0 (* 8 n))))
`((,(string-append "mov____%rbp,%" r))
,(if (< (abs n) #x80) `(,(string-append "add____$i8,%" r) (#:immediate1 ,n))
`(,(string-append "add____$i32,%" r) (#:immediate ,n))))))) ;; FIXME 64bit
(define (x86_64:label->r info label)
(let ((r (get-r info)))
`((,(string-append "mov____$i64,%" r) (#:address8 ,label)))))
(define (x86_64:r0->r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "mov____%" r0 ",%" r1)))))
(define (x86_64:byte-mem->r info)
(let ((r (get-r info)))
`((,(string-append "movzbq_(%" r "),%" r)))))
(define (x86_64:byte-r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "movzbq_%" l ",%" r)))))
(define (x86_64:byte-signed-r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "movsbq_%" l ",%" r)))))
(define (x86_64:word-r info)
(let* ((r (get-r info))
(x (r->x r)))
`((,(string-append "movzwq_%" x ",%" r)))))
(define (x86_64:word-signed-r info)
(let* ((r (get-r info))
(x (r->x r)))
`((,(string-append "movswq_%" x ",%" r)))))
(define (x86_64:long-r info)
(let* ((r (get-r info))
(e (r->e r)))
`((,(string-append "movzlq_%" e ",%" r)))))
(define (x86_64:long-signed-r info)
(let* ((r (get-r info))
(e (r->e r)))
`((,(string-append "movslq_%" e ",%" r)))))
(define (x86_64:jump info label)
`(("jmp32 " (#:offset ,label))))
(define (x86_64:jump-nz info label)
`(("jne32 " (#:offset ,label))))
(define (x86_64:jump-z info label)
`(("je32 " (#:offset ,label))))
(define (x86_64:jump-byte-z info label)
`(("test___%al,%al")
("je32 " (#:offset ,label))))
;; signed
(define (x86_64:jump-g info label)
`(("jg32 " (#:offset ,label))))
(define (x86_64:jump-ge info label)
`(("jge32 " (#:offset ,label))))
(define (x86_64:jump-l info label)
`(("jl32 " (#:offset ,label))))
(define (x86_64:jump-le info label)
`(("jle32 " (#:offset ,label))))
;; unsigned
(define (x86_64:jump-a info label)
`(("ja32 " (#:offset ,label))))
(define (x86_64:jump-ae info label)
`(("jae32 " (#:offset ,label))))
(define (x86_64:jump-b info label)
`(("jb32 " (#:offset ,label))))
(define (x86_64:jump-be info label)
`(("jbe32 " (#:offset ,label))))
(define (x86_64:byte-r0->r1-mem info)
(let* ((r0 (get-r0 info))
(r1 (get-r1 info))
(l0 (r->l r0)))
`((,(string-append "mov____%" l0 ",(%" r1 ")")))))
(define (x86_64:label-mem->r info label)
(let ((r (get-r info)))
`((,(string-append "mov____0x32,%" r) (#:address ,label)))))
(define (x86_64:word-mem->r info)
(let ((r (get-r info)))
`((,(string-append "movzwq_(%" r "),%" r)))))
(define (x86_64:long-mem->r info)
(let ((r (get-r info)))
`((,(string-append "movzlq_(%" r "),%" r)))))
(define (x86_64:mem->r info)
(let ((r (get-r info)))
`((,(string-append "mov____(%" r "),%" r)))))
(define (x86_64:local-add info n v)
(let ((n (- 0 (* 8 n))))
`(,(if (and (< (abs n) #x80)
(< (abs v) #x80)) `("add____$i8,0x8(%rbp)" (#:immediate1 ,n) (#:immediate1 ,v))
`("add____$i32,0x32(%rbp)" (#:immediate ,n) (#:immediate ,v)))))) ;; FIXME: 64b
(define (x86_64:label-mem-add info label v)
`(,(if (< (abs v) #x80) `("add____$i8,0x32" (#:address ,label) (#:immediate1 ,v))
`("add____$i32,0x32" (#:address ,label) (#:immediate ,v))))) ;; FIXME: 64b
(define (x86_64:nop info)
'(("nop")))
(define (x86_64:swap-r0-r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "xchg___%" r0 ",%" r1)))))
;; signed
(define (x86_64:g?->r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "setg___%" l))
(,(string-append "movzbq_%" l ",%" r)))))
(define (x86_64:ge?->r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "setge__%" l))
(,(string-append "movzbq_%" l ",%" r)))))
(define (x86_64:l?->r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "setl___%" l))
(,(string-append "movzbq_%" l ",%" r)))))
(define (x86_64:le?->r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "setle__%" l))
(,(string-append "movzbq_%" l ",%" r)))))
;; unsigned
(define (x86_64:a?->r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "seta___%" l))
(,(string-append "movzbq_%" l ",%" r)))))
(define (x86_64:ae?->r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "setae__%" l))
(,(string-append "movzbq_%" l ",%" r)))))
(define (x86_64:b?->r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "setb___%" l))
(,(string-append "movzbq_%" l ",%" r)))))
(define (x86_64:be?->r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "setbe__%" l))
(,(string-append "movzbq_%" l ",%" r)))))
(define (x86_64:test-r info)
(let ((r (get-r info)))
`((,(string-append "test___%" r ",%" r)))))
(define (x86_64:r->label info label)
(let ((r (get-r info)))
`((,(string-append "mov____%" r ",0x32") (#:address ,label))))) ;; FIXME: 64 bits
(define (x86_64:r->byte-label info label)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "movb___%" l ",0x32") (#:address ,label)))))
(define (x86_64:r->word-label info label)
(let* ((r (get-r info))
(x (r->x r)))
`((,(string-append "movw___%" x ",0x32") (#:address ,label)))))
(define (x86_64:r->long-label info label)
(let* ((r (get-r info))
(e (r->e r)))
`((,(string-append "movl___%" e ",0x32") (#:address ,label)))))
(define (x86_64:call-r info n)
(let ((r (get-r info)))
`((,(string-append "call___*%" r))
("add____$i8,%rsp" (#:immediate1 ,(* n 8)))))) ;; NOT AMD
(define (x86_64:r0*r1 info)
(let ((allocated (.allocated info))
(r0 (get-r0 info))
(r1 (get-r1 info)))
(if (not (member "rdx" allocated))
`(,@(if (equal? r0 "rax") '()
`(("push___%rax"
,(string-append "mov____%" r0 ",%rax"))))
(,(string-append "mul____%" r1))
,@(if (equal? r0 "rax") '()
`((,(string-append "mov____%rax,%" r0)
"pop____%rax"))))
`(("push___%rax")
("push___%rdi")
("push___%rdx")
(,(string-append "mov____%" r1 ",%rdi"))
(,(string-append "mov____%" r0 ",%rax"))
(,(string-append "mul____%" r1))
("pop____%rdx")
("pop____%rdi")
(,(string-append "mov____%rax,%" r0))
("pop____%rax")))))
(define (x86_64:r0<<r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "mov____%" r1 ",%rcx"))
(,(string-append "shl____%cl,%" r0)))))
(define (x86_64:r0>>r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "mov____%" r1 ",%rcx"))
(,(string-append "shr____%cl,%" r0)))))
(define (x86_64:r0-and-r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "and____%" r1 ",%" r0)))))
(define (x86_64:r0/r1 info signed?)
(let ((signed? #f) ; nobody knows, -- all advice are belong to us?
(allocated (.allocated info))
(r0 (get-r0 info))
(r1 (get-r1 info)))
(if (not (member "rdx" allocated))
`(,@(if (equal? r0 "rax") '()
`(("push___%rax")
(,(string-append "mov____%" r0 ",%rax"))))
,(if signed? '("cqto") '("xor____%rdx,%rdx"))
,(if signed? `(,(string-append "idiv___%" r1)) `(,(string-append "div___%" r1)))
,@(if (equal? r0 "rax") '()
`((,(string-append "mov____%rax,%" r0))
("pop____%rax"))))
`(("push___%rax")
("push___%rdi")
("push___%rdx")
(,(string-append "mov____%" r1 ",%rdi"))
(,(string-append "mov____%" r0 ",%rax"))
,(if signed? '("cqto") '("xor____%rdx,%rdx"))
,(if signed? `(,(string-append "idiv___%rdi")) `(,(string-append "div___%rdi")))
("pop____%rdx")
("pop____%rdi")
(,(string-append "mov____%rax,%" r0))
("pop____%rax")))))
(define (x86_64:r0%r1 info signed?)
(let ((signed? #f) ; nobody knows, -- all advice are belong to us?
(allocated (.allocated info))
(r0 (get-r0 info))
(r1 (get-r1 info)))
(if (not (member "rdx" allocated))
`(,@(if (equal? r0 "rax") '()
`(("push___%rax")
(,(string-append "mov____%" r0 ",%rax"))))
,(if signed? '("cqto") '("xor____%rdx,%rdx"))
,(if signed? `(,(string-append "idiv___%" r1)) `(,(string-append "div___%" r1)))
(,(string-append "mov____%rdx,%" r0)))
`(("push___%rax")
("push___%rdi")
("push___%rdx")
(,(string-append "mov____%" r1 ",%rdi"))
(,(string-append "mov____%" r0 ",%rax"))
,(if signed? '("cqto") '("xor____%rdx,%rdx"))
,(if signed? `(,(string-append "idiv___%rdi")) `(,(string-append "div___%rdi")))
("pop____%rdx")
("pop____%rdi")
(,(string-append "mov____%rdx,%" r0))
("pop____%rax")))))
(define (x86_64:r+value info v)
(let ((r (get-r info)))
(cond ((< (abs v) #x80)
`((,(string-append "add____$i8,%" r) (#:immediate1 ,v))))
((< (abs v) #x80000000)
`((,(string-append "add____$i32,%" r) (#:immediate ,v))))
(else
`((,(string-append "mov____$i64,%r15") (#:immediate8 ,v))
(,(string-append "add____%r15,%" r)))))))
(define (x86_64:r0->r1-mem info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "mov____%" r0 ",(%" r1 ")")))))
(define (x86_64:byte-r0->r1-mem info)
(let* ((r0 (get-r0 info))
(r1 (get-r1 info))
(l0 (r->l r0)))
`((,(string-append "mov____%" l0 ",(%" r1 ")")))))
(define (x86_64:word-r0->r1-mem info)
(let* ((r0 (get-r0 info))
(r1 (get-r1 info))
(x0 (r->x r0)))
`((,(string-append "mov____%" x0 ",(%" r1 ")")))))
(define (x86_64:long-r0->r1-mem info)
(let* ((r0 (get-r0 info))
(r1 (get-r1 info))
(e0 (r->e r0)))
`((,(string-append "mov____%" e0 ",(%" r1 ")")))))
(define (x86_64:r-cmp-value info v)
(let ((r (get-r info)))
(cond ((< (abs v) #x80)
`((,(string-append "cmp____$i8,%" r) (#:immediate1 ,v))))
((and (>= v 0)
(< v #xffffffff))
`((,(string-append "cmp____$i32,%" r) (#:immediate ,v))))
(else
`(,(string-append "mov____$i64,%r15") (#:immediate8 ,v)
,(string-append "cmp____%r15,%" r))))))
(define (x86_64:push-register info r)
`((,(string-append "push___%" r))))
(define (x86_64:pop-register info r)
`((,(string-append "pop____%" r))))
(define (x86_64:return->r info)
(let ((r (car (.allocated info))))
(if (equal? r "rax") '()
`((,(string-append "mov____%rax,%" r))))))
(define (x86_64:r0-or-r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "or_____%" r1 ",%" r0)))))
(define (x86_64:shl-r info n)
(let ((r (get-r info)))
`((,(string-append "shl____$i8,%" r) (#:immediate1 ,n)))))
(define (x86_64:r+r info)
(let ((r (get-r info)))
`((,(string-append "add____%" r ",%" r)))))
(define (x86_64:not-r info)
(let ((r (get-r info)))
`((,(string-append "not____%" r)))))
(define (x86_64:r0-xor-r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "xor____%" r1 ",%" r0)))))
(define (x86_64:r0-mem->r1-mem info)
(let* ((registers (.registers info))
(r0 (get-r0 info))
(r1 (get-r1 info))
(r2 (car registers)))
`((,(string-append "mov____(%" r0 "),%" r2))
(,(string-append "mov____%" r2 ",(%" r1 ")")))))
(define (x86_64:byte-r0-mem->r1-mem info)
(let* ((registers (.registers info))
(r0 (get-r0 info))
(r1 (get-r1 info))
(r2 (car registers))
(l2 (r->l r2)))
`((,(string-append "mov____(%" r0 "),%" l2))
(,(string-append "mov____%" l2 ",(%" r1 ")")))))
(define (x86_64:word-r0-mem->r1-mem info)
(let* ((registers (.registers info))
(r0 (get-r0 info))
(r1 (get-r1 info))
(r2 (car registers))
(x2 (r->x r2)))
`((,(string-append "mov____(%" r0 "),%" x2))
(,(string-append "mov____%" x2 ",(%" r1 ")")))))
(define (x86_64:long-r0-mem->r1-mem info)
(let* ((registers (.registers info))
(r0 (get-r0 info))
(r1 (get-r1 info))
(r2 (car registers))
(e2 (r->e r2)))
`((,(string-append "mov____(%" r0 "),%" e2))
(,(string-append "mov____%" e2 ",(%" r1 ")")))))
(define (x86_64:r0+value info v)
(let ((r0 (get-r0 info)))
`(,(if (< (abs v) #x80) `(,(string-append "add____$i8,%" r0) (#:immediate1 ,v))
`(,(string-append "add____$i32,%" r0) (#:immediate ,v)))))) ; FIXME: 64bit
(define (x86_64:value->r0 info v)
(let ((r0 (get-r0 info)))
`((,(string-append "mov____$i32,%" r0) (#:immediate ,v)))))
(define (x86_64:r-long-mem-add info v)
(let ((r (get-r info)))
(cond ((< (abs v) #x80)
`((,(string-append "addl___$i8,(%" r ")") (#:immediate1 ,v))))
((and (>= v 0)
(< v #xffffffff))
`((,(string-append "addl___$i32,(%" r ")") (#:immediate ,v))))
(else
`((,(string-append "mov____$i64,%r15") (#:immediate8 ,v))
(,(string-append "add____%r15,(%" r ")")))))))
(define (x86_64:byte-r->local+n info id n)
(let* ((n (+ (- 0 (* 8 id)) n))
(r (get-r info))
(l (r->l r) ))
`(,(if (< (abs n) #x80) `(,(string-append "mov____%" l ",0x8(%rbp)") (#:immediate1 ,n))
`(,(string-append "mov____%" l ",0x32(%rbp)") (#:immediate ,n))))))
(define (x86_64:word-r->local+n info id n)
(let* ((n (+ (- 0 (* 8 id)) n))
(r (get-r info))
(x (r->x r) ))
`(,(if (< (abs n) #x80) `(,(string-append "mov____%" x ",0x8(%rbp)") (#:immediate1 ,n))
`(,(string-append "mov____%" x ",0x32(%rbp)") (#:immediate ,n))))))
(define (x86_64:long-r->local+n info id n)
(let* ((n (+ (- 0 (* 8 id)) n))
(r (get-r info))
(e (r->e r)))
`(,(if (< (abs n) #x80) `(,(string-append "mov____%" e ",0x8(%rbp)") (#:immediate1 ,n))
`(,(string-append "mov____%" e ",0x32(%rbp)") (#:immediate ,n))))))
(define (x86_64:r-and info v)
(let ((r (get-r info)))
(if (and (>= v 0)
(< v #xffffffff))
`((,(string-append "and____$i32,%" r) (#:immediate ,v)))
`((,(string-append "mov____$i64,%r15") (#:immediate8 ,v))
(,(string-append "and____%r15,%" r))))))
(define (x86_64:push-r0 info)
(let ((r0 (get-r0 info)))
`((,(string-append "push___%" r0)))))
(define (x86_64:r1->r0 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "mov____%" r1 ",%" r0)))))
(define (x86_64:pop-r0 info)
(let ((r0 (get-r0 info)))
`((,(string-append "pop____%" r0)))))
(define (x86_64:swap-r-stack info)
(let ((r (get-r info)))
`((,(string-append "xchg___%" r ",(%rsp)")))))
(define (x86_64:swap-r1-stack info)
(let ((r0 (get-r0 info)))
`((,(string-append "xchg___%" r0 ",(%rsp)")))))
(define (x86_64:r2->r0 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info))
(allocated (.allocated info)))
(if (> (length allocated) 2)
(let ((r2 (cadddr allocated)))
`((,(string-append "mov____%" r2 ",%" r1))))
`((,(string-append "pop____%" r0))
(,(string-append "push___%" r0))))))
(define x86_64:instructions
`(
(a?->r . ,x86_64:a?->r)
(ae?->r . ,x86_64:ae?->r)
(b?->r . ,x86_64:b?->r)
(be?->r . ,x86_64:be?->r)
(byte-mem->r . ,x86_64:byte-mem->r)
(byte-r . ,x86_64:byte-r)
(byte-r->local+n . ,x86_64:byte-r->local+n)
(byte-r0->r1-mem . ,x86_64:byte-r0->r1-mem)
(byte-r0-mem->r1-mem . ,x86_64:byte-r0-mem->r1-mem)
(byte-signed-r . ,x86_64:byte-signed-r)
(call-label . ,x86_64:call-label)
(call-r . ,x86_64:call-r)
(function-locals . ,x86_64:function-locals)
(function-preamble . ,x86_64:function-preamble)
(g?->r . ,x86_64:g?->r)
(ge?->r . ,x86_64:ge?->r)
(jump . ,x86_64:jump)
(jump-a . ,x86_64:jump-a)
(jump-ae . ,x86_64:jump-ae)
(jump-b . ,x86_64:jump-b)
(jump-be . ,x86_64:jump-be)
(jump-byte-z . ,x86_64:jump-byte-z)
(jump-g . , x86_64:jump-g)
(jump-ge . , x86_64:jump-ge)
(jump-l . ,x86_64:jump-l)
(jump-le . ,x86_64:jump-le)
(jump-nz . ,x86_64:jump-nz)
(jump-z . ,x86_64:jump-z)
(l?->r . ,x86_64:l?->r)
(label->arg . ,x86_64:label->arg)
(label->r . ,x86_64:label->r)
(label-mem->r . ,x86_64:label-mem->r)
(label-mem-add . ,x86_64:label-mem-add)
(le?->r . ,x86_64:le?->r)
(local->r . ,x86_64:local->r)
(local-add . ,x86_64:local-add)
(local-ptr->r . ,x86_64:local-ptr->r)
(long-mem->r . ,x86_64:long-mem->r)
(long-r . ,x86_64:long-r)
(long-r->local+n . ,x86_64:long-r->local+n)
(long-r0->r1-mem . ,x86_64:long-r0->r1-mem)
(long-r0-mem->r1-mem . ,x86_64:long-r0-mem->r1-mem)
(long-signed-r . ,x86_64:long-signed-r)
(mem->r . ,x86_64:mem->r)
(nop . ,x86_64:nop)
(not-r . ,x86_64:not-r)
(pop-r0 . ,x86_64:pop-r0)
(pop-register . ,x86_64:pop-register)
(push-r0 . ,x86_64:push-r0)
(push-register . ,x86_64:push-register)
(quad-r0->r1-mem . ,x86_64:r0->r1-mem)
(r+r . ,x86_64:r+r)
(r+value . ,x86_64:r+value)
(r->arg . ,x86_64:r->arg)
(r->byte-label . ,x86_64:r->byte-label)
(r->label . ,x86_64:r->label)
(r->local . ,x86_64:r->local)
(r->local+n . ,x86_64:r->local+n)
(r->long-label . ,x86_64:r->long-label)
(r->word-label . ,x86_64:r->word-label)
(r-and . ,x86_64:r-and)
(r-byte-mem-add . ,x86_64:r-byte-mem-add)
(r-cmp-value . ,x86_64:r-cmp-value)
(r-long-mem-add . ,x86_64:r-long-mem-add)
(r-mem-add . ,x86_64:r-mem-add)
(r-negate . ,x86_64:r-negate)
(r-word-mem-add . ,x86_64:r-word-mem-add)
(r-zero? . ,x86_64:r-zero?)
(r0%r1 . ,x86_64:r0%r1)
(r0*r1 . ,x86_64:r0*r1)
(r0+r1 . ,x86_64:r0+r1)
(r0+value . ,x86_64:r0+value)
(r0->r1 . ,x86_64:r0->r1)
(r0->r1-mem . ,x86_64:r0->r1-mem)
(r0-and-r1 . ,x86_64:r0-and-r1)
(r0-mem->r1-mem . ,x86_64:r0-mem->r1-mem)
(r0-or-r1 . ,x86_64:r0-or-r1)
(r0-r1 . ,x86_64:r0-r1)
(r0-xor-r1 . ,x86_64:r0-xor-r1)
(r0/r1 . ,x86_64:r0/r1)
(r0<<r1 . ,x86_64:r0<<r1)
(r0>>r1 . ,x86_64:r0>>r1)
(r1->r0 . ,x86_64:r1->r0)
(r2->r0 . ,x86_64:r2->r0)
(ret . ,x86_64:ret)
(return->r . ,x86_64:return->r)
(shl-r . ,x86_64:shl-r)
(swap-r-stack . ,x86_64:swap-r-stack)
(swap-r0-r1 . ,x86_64:swap-r0-r1)
(swap-r1-stack . ,x86_64:swap-r1-stack)
(test-r . ,x86_64:test-r)
(value->r . ,x86_64:value->r)
(value->r0 . ,x86_64:value->r0)
(word-mem->r . ,x86_64:word-mem->r)
(word-r . ,x86_64:word-r)
(word-r->local+n . ,x86_64:word-r->local+n)
(word-r0->r1-mem . ,x86_64:word-r0->r1-mem)
(word-r0-mem->r1-mem . ,x86_64:word-r0-mem->r1-mem)
(word-signed-r . ,x86_64:word-signed-r)
(xor-zf . ,x86_64:xor-zf)
(zf->r . ,x86_64:zf->r)
))

61
sysa/mes-0.22/module/mescc/x86_64/info.scm Normal file
View file

@ -0,0 +1,61 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 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:
;;; Initialize MesCC as i386/x86 compiler
;;; Code:
(define-module (mescc x86_64 info)
#:use-module (mescc info)
#:use-module (mescc x86_64 as)
#:export (x86_64-info
x86_64:registers))
(define (x86_64-info)
(make <info> #:types x86_64:type-alist #:registers x86_64:registers #:instructions x86_64:instructions))
(define x86_64:registers '("rax" "rdi" "rsi" "rdx" "rcx" "r8" "r9" "r10" "r11" "r12" "r13" "r14" "r15"))
(define x86_64:type-alist
`(("char" . ,(make-type 'signed 1 #f))
("short" . ,(make-type 'signed 2 #f))
("int" . ,(make-type 'signed 4 #f))
("long" . ,(make-type 'signed 8 #f))
("default" . ,(make-type 'signed 4 #f))
("*" . ,(make-type 'unsigned 8 #f))
("long long" . ,(make-type 'signed 8 #f))
("long long int" . ,(make-type 'signed 8 #f))
("void" . ,(make-type 'void 1 #f))
("unsigned char" . ,(make-type 'unsigned 1 #f))
("unsigned short" . ,(make-type 'unsigned 2 #f))
("unsigned" . ,(make-type 'unsigned 4 #f))
("unsigned int" . ,(make-type 'unsigned 4 #f))
("unsigned long" . ,(make-type 'unsigned 8 #f))
("unsigned long long" . ,(make-type 'unsigned 8 #f))
("unsigned long long int" . ,(make-type 'unsigned 8 #f))
("float" . ,(make-type 'float 4 #f))
("double" . ,(make-type 'float 8 #f))
("long double" . ,(make-type 'float 8 #f))
("short int" . ,(make-type 'signed 2 #f))
("unsigned short int" . ,(make-type 'unsigned 2 #f))
("long int" . ,(make-type 'signed 8 #f))
("unsigned long int" . ,(make-type 'unsigned 8 #f))))