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