4d59ee8d9d50c3da41947507dd28342c6cd64447
[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? verbose?)
39   (let ((info (fold M1:merge-infos (make <info>) infos)))
40     (info->M1 file-name info #:align? align? #:verbose? verbose?)))
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 mesc? (string=? %compiler "mesc"))
85
86 (define (hex2:immediate8 o)
87   ;; FIXME: #x100000000 => 0 divide-by-zero when compiled with 64 bit mesc
88   (if hex? (string-append "%0x" (dec->hex (if mesc? 0 (modulo o #x100000000)))
89                           " %0x" (if (< o 0) "-1"
90                                      (dec->hex (if mesc? o (quotient o #x100000000)))))
91       (string-append "%" (number->string (dec->hex (if mesc? 0 (modulo o #x100000000))))
92                      " %" (if (< o 0) "-1"
93                               (number->string (dec->hex (if mesc? o (quotient o #x100000000))))))))
94
95 (define* (display-join o #:optional (sep ""))
96   (let loop ((o o))
97     (when (pair? o)
98       (display (car o))
99       (if (pair? (cdr o))
100           (display sep))
101       (loop (cdr o)))))
102
103 (define* (info->M1 file-name o #:key align? verbose?)
104   (let* ((functions (.functions o))
105          (function-names (map car functions))
106          (globals (.globals o))
107          (global-names (map car globals))
108          (strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names))
109          (reg-size (type:size (assoc-ref (.types o) "*"))))
110     (define (string->label o)
111       (let ((index (list-index (lambda (s) (equal? s o)) strings)))
112         (if index
113             (string-append "_string_" file-name "_" (number->string index))
114             (if (equal? o "%0") o       ; FIXME: 64b
115                 (error "no such string:" o)))))
116     (define (text->M1 o)
117       ;;
118       (cond
119        ((char? o) (text->M1 (char->integer o)))
120        ((string? o) o)
121        ((symbol? o) (symbol->string o))
122        ((number? o) (let ((o (if (< o #x80) o (- o #x100))))
123                       (if hex? (string-append "!0x"
124                                               (if (and (>= o 0) (< o 16)) "0" "")
125                                               (number->string o 16))
126                           (string-append "!" (number->string o)))))
127        ((and (pair? o) (keyword? (car o)))
128         (pmatch o
129           ;; FIXME
130           ((#:address (#:string ,string))
131            (hex2:address (string->label `(#:string ,string))))
132           ((#:address (#:address ,address)) (guard (string? address))
133            (hex2:address address))
134           ((#:address (#:address ,global)) (guard (global? global))
135            (hex2:address (global->string global)))
136           ((#:address ,function) (guard (function? function))
137            (hex2:address (function->string function)))
138           ((#:address ,number) (guard (number? number))
139            (string-join (map text->M1 (int->bv32 number))))
140
141           ((#:address8 (#:string ,string))
142            (hex2:address8 (string->label `(#:string ,string))))
143           ((#:address8 (#:address ,address)) (guard (string? address))
144            (hex2:address8 address))
145           ((#:address8 (#:address ,global)) (guard (global? global))
146            (hex2:address8 (global->string global)))
147           ((#:address8 ,function) (guard (function? function))
148            (hex2:address8 (function->string function)))
149           ((#:address8 ,number) (guard (number? number))
150            (string-join (map text->M1 (int->bv64 number))))
151
152           ((#:string ,string)
153            (hex2:address (string->label o)))
154
155           ((#:address ,address) (guard (string? address))
156            (hex2:address address))
157           ((#:address ,global) (guard (global? global))
158            (hex2:address (global->string global)))
159
160           ((#:address8 ,address) (guard (string? address))
161            (hex2:address8 address))
162           ((#:address8 ,global) (guard (global? global))
163            (hex2:address8 (global->string global)))
164
165           ((#:offset ,offset) (hex2:offset offset))
166           ((#:offset1 ,offset1) (hex2:offset1 offset1))
167           ((#:immediate ,immediate) (hex2:immediate immediate))
168           ((#:immediate1 ,immediate1) (hex2:immediate1 immediate1))
169           ((#:immediate2 ,immediate2) (hex2:immediate2 immediate2))
170           ((#:immediate4 ,immediate4) (hex2:immediate4 immediate4))
171           ((#:immediate8 ,immediate8) (hex2:immediate8 immediate8))
172           (_ (error "text->M1 no match o" o))))
173        ((pair? o) (string-join (map text->M1 o)))
174        (#t (error "no such text:" o))))
175     (define (write-function o)
176       (let ((name (car o))
177             (text (function:text (cdr o))))
178         (define (line->M1 o)
179           (cond ((eq? (car o) #:label)
180                  (display (string-append ":" (cadr o))))
181                 ((eq? (car o) #:comment)
182                  (display "\t\t\t\t\t# ")
183                  (display (text->M1 (cadr o))))
184                 ((or (string? (car o)) (symbol? (car o)))
185                  (display "\t" )
186                  (display-join (map text->M1 o) " "))
187                 (else (error "line->M1 invalid line:" o)))
188           (newline))
189         (when verbose?
190           (display (string-append "    :" name "\n") (current-error-port)))
191         (display (string-append "\n\n:" name "\n"))
192         (for-each line->M1 (apply append text))))
193     (define (write-global o)
194       (define (labelize o)
195         (if (not (string? o)) o
196             (let* ((label o)
197                    (function? (member label function-names))
198                    (string-label (string->label label))
199                    (string? (not (equal? string-label "_string_#f"))))
200               (cond ((and (pair? o) (global? (cdr o))) (string-append "&" (global->string o)))
201                     ((and (not string?) (not function?)) (stderr "warning: unresolved label: ~s\n" label))
202                     ((equal? string-label "%0") o) ;; FIXME: 64b
203                     (else (string-append "&" label))))))
204       (define (display-align size)
205         (let ((alignment (- reg-size (modulo size reg-size))))
206           (when (and align? (> reg-size alignment 0))
207             (display " ")
208             (display-join (map text->M1 (map (const 0) (iota alignment))) " "))
209           #t))
210       (let* ((label (cond
211                      ((and (pair? (car o)) (eq? (caar o) #:string))
212                       (string->label (car o)))
213                      ((global? (cdr o)) (global->string (cdr o)))
214                      (else (car o))))
215              (string? (string-prefix? "_string" label))
216              (foo (when (and verbose? (not (eq? (car (string->list label)) #\_)))
217                     (display (string-append "    :" label "\n") (current-error-port))))
218              (data ((compose global:value cdr) o))
219              (data (filter-map labelize data))
220              (len (length data))
221              (string-max (or (and=> (getenv "M1_STRING_MAX") string->number) 256))
222              (string-data (and string? (list-head data (1- (length data))))))
223         (display (string-append "\n:" label "\n"))
224         (if (and string-data
225                  (< len string-max)
226                  (char? (car data))
227                  (eq? (last data) #\nul)
228                  (not (find (cut memq <> '(#\")) string-data))
229                  (not (any (lambda (ch)
230                              (or (and (not (memq ch '(#\tab #\newline)))
231                                       (< (char->integer ch) #x20))
232                                  (>= (char->integer ch) #x80))) string-data)))
233             (let ((text string-data))
234               (display (string-append "\"" (list->string string-data) "\""))
235               (display-align (1+ (length string-data))))
236             (let ((text (map text->M1 data)))
237               (display-join  text " ")
238               (display-align (length text))))
239         (newline)))
240     (when verbose?
241       (display "M1: functions\n" (current-error-port)))
242     (for-each write-function (filter cdr functions))
243     (when (assoc-ref functions "main")
244       (display "\n\n:ELF_data\n") ;; FIXME
245       (display "\n\n:HEX2_data\n"))
246     (when verbose?
247       (display "M1: globals\n" (current-error-port)))
248     (for-each write-global globals)))