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