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