mescc: Oops typo.
[mes.git] / module / mescc / M1.scm
1 ;;; GNU Mes --- Maxwell Equations of Software
2 ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
3 ;;;
4 ;;; This file is part of GNU Mes.
5 ;;;
6 ;;; GNU Mes is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or (at
9 ;;; your option) any later version.
10 ;;;
11 ;;; GNU Mes is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 ;;; GNU General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
18
19 ;;; Commentary:
20
21 ;;; M1.scm produces stage0' M1 assembly format
22
23 ;;; Code:
24
25 (define-module (mescc M1)
26   #:use-module (srfi srfi-1)
27   #:use-module (srfi srfi-26)
28   #:use-module (system base pmatch)
29   #:use-module (mes misc)
30   #:use-module (mes guile)
31
32   #:use-module (mescc as)
33   #:use-module (mescc info)
34   #:export (info->M1
35             infos->M1
36             M1:merge-infos))
37
38 (define* (infos->M1 file-name infos #:key align?)
39   (let ((info (fold M1:merge-infos (make <info>) infos)))
40     (info->M1 file-name info #:align? align?)))
41
42 (define (M1:merge-infos o info)
43   (clone info
44          #:functions (alist-add (.functions info) (.functions o))
45          #:globals (alist-add (.globals info) (.globals o))
46          #:types (.types o)))
47
48 (define (alist-add a b)
49   (let* ((b-keys (map car b))
50          (a (filter (lambda (f) (or (cdr f) (not (member (car f) b-keys)))) a))
51          (a-keys (map car a)))
52     (append a (filter (lambda (e) (not (member (car e) a-keys))) b))))
53
54 (define (hex2:address o)
55   (string-append "&" o))
56
57 (define (hex2:address8 o)
58   (string-append "&" o " %0")) ;; FIXME: 64bit
59
60 (define (hex2:offset o)
61   (string-append "%" o))
62
63 (define (hex2:offset1 o)
64   (string-append "!" o))
65
66 (define hex? #t)
67
68 (define (hex2:immediate o)
69   (if hex? (string-append "%0x" (dec->hex o))
70       (string-append "%" (number->string o))))
71
72 (define (hex2:immediate1 o)
73   (if hex? (string-append "!0x" (dec->hex o))
74       (string-append "!" (number->string o))))
75
76 (define (hex2:immediate2 o)
77   (if hex? (string-append "@0x" (dec->hex o))
78       (string-append "@" (number->string o))))
79
80 (define (hex2:immediate4 o)
81   (if hex? (string-append "%0x" (dec->hex o))
82       (string-append "%" (number->string o))))
83
84 (define (hex2:immediate8 o)
85   (if hex? (string-append "%0x" (dec->hex (modulo o #x100000000))
86                           " %0x" (if (< o 0) "-1"
87                                      (dec->hex (quotient o #x100000000))))
88       (string-append "%" (number->string (dec->hex (modulo o #x100000000)))
89                      " %" (if (< o 0) "-1"
90                               (number->string (dec->hex (quotient o #x100000000)))))))
91
92 (define* (display-join o #:optional (sep ""))
93   (let loop ((o o))
94     (when (pair? o)
95       (display (car o))
96       (if (pair? (cdr o))
97           (display sep))
98       (loop (cdr o)))))
99
100 (define* (info->M1 file-name o #:key align?)
101   (let* ((functions (.functions o))
102          (function-names (map car functions))
103          (globals (.globals o))
104          (global-names (map car globals))
105          (strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names))
106          (reg-size (type:size (assoc-ref (.types o) "*"))))
107     (define (string->label o)
108       (let ((index (list-index (lambda (s) (equal? s o)) strings)))
109         (if index
110             (string-append "_string_" file-name "_" (number->string index))
111             (if (equal? o "%0") o       ; FIXME: 64b
112                 (error "no such string:" o)))))
113     (define (text->M1 o)
114       (cond
115        ((char? o) (text->M1 (char->integer o)))
116        ((string? o) o)
117        ((symbol? o) (symbol->string o))
118        ((number? o) (let ((o (if (< o #x80) o (- o #x100))))
119                       (if hex? (string-append "!0x"
120                                               (if (and (>= o 0) (< o 16)) "0" "")
121                                               (number->string o 16))
122                           (string-append "!" (number->string o)))))
123        ((and (pair? o) (keyword? (car o)))
124         (pmatch o
125           ;; FIXME
126           ((#:address (#:string ,string))
127            (hex2:address (string->label `(#:string ,string))))
128           ((#:address (#:address ,address)) (guard (string? address))
129            (hex2:address address))
130           ((#:address (#:address ,global)) (guard (global? global))
131            (hex2:address (global->string global)))
132           ((#:address ,function) (guard (function? function))
133            (hex2:address (function->string function)))
134           ((#:address ,number) (guard (number? number))
135            (string-join (map text->M1 (int->bv32 number))))
136
137           ((#:address8 (#:string ,string))
138            (hex2:address8 (string->label `(#:string ,string))))
139           ((#:address8 (#:address ,address)) (guard (string? address))
140            (hex2:address8 address))
141           ((#:address8 (#:address ,global)) (guard (global? global))
142            (hex2:address8 (global->string global)))
143           ((#:address8 ,function) (guard (function? function))
144            (hex2:address8 (function->string function)))
145           ((#:address8 ,number) (guard (number? number))
146            (string-join (map text->M1 (int->bv64 number))))
147
148           ((#:string ,string)
149            (hex2:address (string->label o)))
150
151           ((#:address ,address) (guard (string? address))
152            (hex2:address address))
153           ((#:address ,global) (guard (global? global))
154            (hex2:address (global->string global)))
155
156           ((#:address8 ,address) (guard (string? address))
157            (hex2:address8 address))
158           ((#:address8 ,global) (guard (global? global))
159            (hex2:address8 (global->string global)))
160
161           ((#:offset ,offset) (hex2:offset offset))
162           ((#:offset1 ,offset1) (hex2:offset1 offset1))
163           ((#:immediate ,immediate) (hex2:immediate immediate))
164           ((#:immediate1 ,immediate1) (hex2:immediate1 immediate1))
165           ((#:immediate2 ,immediate2) (hex2:immediate2 immediate2))
166           ((#:immediate4 ,immediate4) (hex2:immediate4 immediate4))
167           ((#:immediate8 ,immediate8) (hex2:immediate8 immediate8))
168           (_ (error "text->M1 no match o" o))))
169        ((pair? o) (string-join (map text->M1 o)))))
170     (define (write-function o)
171       (let ((name (car o))
172             (text (function:text (cdr o))))
173         (define (line->M1 o)
174           (cond ((eq? (car o) #:label)
175                  (display (string-append ":" (cadr o))))
176                 ((eq? (car o) #:comment)
177                  (display "\t\t\t\t\t# ")
178                  (display (text->M1 (cadr o))))
179                 ((or (string? (car o)) (symbol? (car o)))
180                  (display "\t" )
181                  (display-join (map text->M1 o) " "))
182                 (else (error "line->M1 invalid line:" o)))
183           (newline))
184         (display (string-append "    :" name "\n") (current-error-port))
185         (display (string-append "\n\n:" name "\n"))
186         (for-each line->M1 (apply append text))))
187     (define (write-global o)
188       (define (labelize o)
189         (if (not (string? o)) o
190             (let* ((label o)
191                    (function? (member label function-names))
192                    (string-label (string->label label))
193                    (string? (not (equal? string-label "_string_#f"))))
194               (cond ((and (pair? o) (global? (cdr o))) (string-append "&" (global->string o)))
195                     ((and (not string?) (not function?)) (stderr "warning: unresolved label: ~s\n" label))
196                     ((equal? string-label "%0") o) ;; FIXME: 64b
197                     (else (string-append "&" label))))))
198       (define (display-align size)
199         (let ((alignment (- reg-size (modulo size reg-size))))
200           (when (and align? (> reg-size alignment 0))
201             (display " ")
202             (display-join (map text->M1 (map (const 0) (iota alignment))) " "))
203           #t))
204       (let* ((label (cond
205                      ((and (pair? (car o)) (eq? (caar o) #:string))
206                       (string->label (car o)))
207                      ((global? (cdr o)) (global->string (cdr o)))
208                      (else (car o))))
209              (string? (string-prefix? "_string" label))
210              (foo (if (not (eq? (car (string->list label)) #\_))
211                       (display (string-append "    :" label "\n") (current-error-port))))
212              (data ((compose global:value cdr) o))
213              (data (filter-map labelize data))
214              (len (length data))
215              (string-max (or (and=> (getenv "M1_STRING_MAX") string->number) 256))
216              (string-data (and string? (list-head data (1- (length data))))))
217         (display (string-append "\n:" label "\n"))
218         (if (and string-data
219                  (< len string-max)
220                  (char? (car data))
221                  (eq? (last data) #\nul)
222                  (not (find (cut memq <> '(#\")) string-data))
223                  (not (any (lambda (ch)
224                              (or (and (not (memq ch '(#\tab #\newline)))
225                                       (< (char->integer ch) #x20))
226                                  (>= (char->integer ch) #x80))) string-data)))
227             (let ((text string-data))
228               (display (string-append "\"" (list->string string-data) "\""))
229               (display-align (1+ (length string-data))))
230             (let ((text (map text->M1 data)))
231               (display-join  text " ")
232               (display-align (length text))))
233         (newline)))
234     (display "M1: functions\n" (current-error-port))
235     (for-each write-function (filter cdr functions))
236     (when (assoc-ref functions "main")
237       (display "\n\n:ELF_data\n") ;; FIXME
238       (display "\n\n:HEX2_data\n"))
239     (display "M1: globals\n" (current-error-port))
240     (for-each write-global globals)))