mescc: Remove jump calculation, use labels: prepare.
[mes.git] / module / mes / hex2.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; This file is part of Mes.
7 ;;;
8 ;;; Mes is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
12 ;;;
13 ;;; Mes is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;;; GNU General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;;; Commentary:
22
23 ;;; hex2.mes produces stage0' hex2 object format
24
25 ;;; Code:
26
27 (cond-expand
28  (guile)
29  (mes
30   (mes-use-module (srfi srfi-1))
31   (mes-use-module (mes elf-util))
32   (mes-use-module (mes elf))
33   (mes-use-module (mes optargs))))
34
35 (define (logf port string . rest)
36   (apply format (cons* port string rest))
37   (force-output port)
38   #t)
39
40 (define (stderr string . rest)
41   (apply logf (cons* (current-error-port) string rest)))
42
43 (define (dec->xhex o)
44   (if (number? o) (string-append "#x" (dec->hex o))
45       (format #f "~s" o)))
46
47 (define (write-hex3 o)
48   (define (write-line o)
49     (cond ((null? o))
50           ((not (pair? o))
51            (display (dec->xhex o)))
52           ((string? (car o))
53            (format #t ";; ~a\n" (car o))
54            (display (string-join (map dec->xhex (cdr o)) " ")))
55           ((number? (car o))
56            (display (string-join (map dec->xhex o) " ")))
57           ((member (car o) '(#:comment #:label))
58            (write o))
59           ((and (pair? (car o)) (member (caar o) '(#:comment #:label)))
60            (write (car o)))
61           (else (error "write-line LINE:" o))))
62   (define (write-function o)
63     (stderr "function: ~s\n" (car o))
64     (format #t "\n(~s " (car o))
65     (if (pair? (cadr o)) (for-each
66                           (lambda (x) (display "\n  (") (write-line x) (display ")"))
67                           (filter pair? (cdr o)))
68         (write-line o))
69     (display ")"))
70   (define (write-global o)
71     (stderr "global: ~s\n" (car o))
72     (format #t "\n(~s "(car o))
73     (display (string-join (map dec->xhex (cdr o)) " "))
74     (display ")"))
75   (define (write-init o)
76     (stderr "init: ~s\n" o)
77     (format #t "\n  (~s "(car o))
78     (display (string-join (map dec->xhex (global:value (cdr o))) " "))
79     (display ")"))
80   (stderr "object:\n")
81   (display ";;; hex3: hex2 in sexps with annotated labels\n")
82   (display "((functions ")
83   (for-each write-function (filter cdr (assoc-ref o 'functions)))
84   (display ")\n")
85   (display "(globals ")
86   (for-each write-global (assoc-ref o 'globals))
87   (display "))\n"))
88
89 (define (objects->hex2 objects)
90   ((compose write-hex2 merge-objects) objects))
91
92 (define (objects->hex3 objects)
93   ((compose write-hex3 merge-objects) objects))
94
95 (define (objects->elf objects)
96   ((compose object->elf merge-objects) objects))
97
98 (define (merge-objects objects)
99   (let loop ((objects (cdr objects)) (object (car objects)))
100     (if (null? objects) object
101         (loop (cdr objects)
102               `((functions . ,(alist-add (assoc-ref object 'functions) (assoc-ref (car objects) 'functions)))
103                 (globals . ,(alist-add (assoc-ref object 'globals) (assoc-ref (car objects) 'globals))))))))
104
105 (define (alist-add a b)
106   (let* ((b-keys (map car b))
107          (a (filter (lambda (f) (or (cdr f) (not (member (car f) b-keys)))) a))
108          (a-keys (map car a)))
109     (append a (filter (lambda (e) (not (member (car e) a-keys))) b))))
110
111 (define (write-hex2 o)
112   (let* ((functions (assoc-ref o 'functions))
113          (function-names (map car functions))
114          (globals (assoc-ref o 'globals))
115          (global-names (map car globals))
116          (strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names)))
117     (define (string->label o)
118       (format #f "string_~a" (list-index (lambda (s) (equal? s o)) strings)))
119     (define (dec->hex o)
120       (cond ((number? o) (string-append (if (and (>= o 0) (< o 16)) "0" "")
121                                         (number->string
122                                          (if (>= o 0) o (+ o #x100))
123                                          16)))
124             ((char? o) (dec->hex (char->integer o)))
125             ((and (pair? o) (eq? (car o) #:string))
126              (format #f "&~a" (string->label o)))
127             ((string? o) (format #f "~a" o))
128             (else (format #f "~a" o))))
129     (define (write-line function)
130       (lambda (o)
131         (newline)
132         (cond ((not (pair? o))
133                (display (dec->hex o)))
134               ((number? (car o))
135                ;;(display (string-join (map dec->hex (filter identity o)) " "))
136                ;; FIXME: c&p from elf-util: function->text
137                (let ((text (let loop ((text o))
138                              (if (null? text) '()
139                                  (let ((label (car text)))
140                                    (if (number? label) (cons label (loop (cdr text)))
141                                        (if (and (pair? label) (member (car label) '(#:comment #:label))) (loop (cdr text))
142                                            (let* ((prefix (cond ((and (pair? (cdr text))
143                                                                       (pair? (cddr text))
144                                                                       (boolean? (caddr text))) 4)
145                                                                 ((and (pair? (cdr text))
146                                                                       (boolean? (cadr text))) 2)
147                                                                 (else 1)))
148                                                   (address? (and (pair? label) (eq? (car label) #:address)))
149                                                   (local? (and (pair? label) (eq? (car label) #:local)))
150                                                   (relative? (and (pair? label) (eq? (car label) #:relative)))
151                                                   (label (if (or address? local? relative?) (cadr label) label))
152                                                   (function? (member label function-names))
153                                                   (string-label (string->label label))
154                                                   (string? (not (equal? string-label "string_#f")))
155                                                   (global? (member label global-names))
156                                                   (label (if local? (string-append "local_" function "_" label) label)))
157                                              (cons (cond
158                                                     ((eq? prefix 1) (format #f "!~a" label))
159                                                     ((eq? prefix 2) (format #f "@~a" label))
160                                                     (local? (format #f "%~a" label))
161                                                     (function? (if address? (format #f "&~a" label)
162                                                                    (format #f "%~a" label)))
163                                                     (string? (format #f "&~a" string-label))
164                                                     (global? (format #f "&~a" label))
165                                                     (else (format #f "%~a" label)))
166                                                    (loop (list-tail text prefix)))))))))))
167                  (display (string-join (map dec->hex text) " "))))
168               ((member (car o) '(#:comment))
169                (format #t "# ~s" (cadr o)))
170               ((eq? (car o) #:label)
171                (format #t ":local_~a_~a\n" function (cadr o)))
172               ((and (pair? (car o)) (eq? (caar o) #:label))
173                (format #t ":local_~a\n" (cadar o)))
174               ((and (pair? (car o)) (member (caar o) '(#:comment)))
175                (format #t "# ~s" (cadar o)))
176               ((and (pair? (car o)) (member (caar o) '(#:comment #:label)))
177                (write (car o)))
178               (else (error "write-line LINE:" o)))))
179     (define (write-function o)
180       (format #t "\n\n:~a" (car o))
181       (if (pair? (cadr o)) (for-each (write-line (car o)) (cdr o))
182           ((write-line (car o)) (cdr o))))
183     (define (write-global o)
184       (define (labelize o)
185         (if (not (string? o)) o
186             (let* ((label o)
187                    (function? (member label function-names))
188                    (string-label (string->label label))
189                    (string? (not (equal? string-label "string_#f")))
190                    (global? (member label global-names)))
191               (if (or global? string?) (format #f "&~a" label)
192                   (begin (if (not function?) (stderr "warning: unresolved label: ~s\n" label))
193                          (format #f "&~a" label))))))
194       (let* ((label (if (not (and (pair? (car o)) (eq? (caar o) #:string))) (car o)
195                        (string->label (car o))))
196              (data (cdr o))
197              (data (filter-map labelize data)))
198         (format #t "\n:~a\n" label)
199         (display (string-join (map dec->hex data) " "))
200         (newline)))
201     (display "### stage0's hex2 format for x86\n")
202     (display "###    !<label>          1 byte relative\n")
203     (display "###    $<label>          2 byte address\n")
204     (display "###    @<label>          2 byte relative\n")
205     (display "###    &<label>          4 byte address\n")
206     (display "###    %<label>          4 byte relative\n")
207     (display "###    local_<label>     function-local\n")
208     (display "###    string_<index>    string #<index>\n")
209     (display "\n##.text")
210     (for-each write-function (filter cdr functions))
211     (display "\n\n##.data\n")
212     (for-each write-global globals)))