mescc: Remove jump calculation, use labels: prepare.
[mes.git] / module / mes / elf-util.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,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 ;;; compiler.mes produces an i386 binary from the C produced by
24 ;;; Nyacc c99.
25
26 ;;; Code:
27
28 (cond-expand
29  (guile)
30  (guile-2)
31  (mes
32   (mes-use-module (srfi srfi-1))
33   (mes-use-module (srfi srfi-1))))
34
35
36 (define (int->bv32 value)
37   (let ((bv (make-bytevector 4)))
38     (bytevector-u32-native-set! bv 0 value)
39     bv))
40
41 (define (int->bv16 value)
42   (let ((bv (make-bytevector 2)))
43     (bytevector-u16-native-set! bv 0 value)
44     bv))
45
46 (define (make-global name type pointer value)
47   (cons name (list type pointer value)))
48
49 (define global:type car)
50 (define global:pointer cadr)
51 (define global:value caddr)
52
53 (define (dec->hex o)
54   (cond ((number? o) (number->string o 16))
55         ((char? o) (number->string (char->integer o) 16))
56         (else (format #f "~s" o))))
57
58 (define (functions->lines functions)
59   (filter (lambda (x) (not (and (pair? x) (pair? (car x)) (member (caar x) '(#:comment #:label))))) (append-map cdr functions))
60   ;;(append-map cdr functions)
61   )
62
63 (define (text->list o)
64   (append-map cdr o))
65
66 (define functions->text
67   (let ((cache '()))
68     (lambda (functions globals ta t d)
69       (let ((text (or (assoc-ref cache (cons ta (map car functions)))
70                       (let ((text (apply append (functions->lines functions))))
71                     (set! cache (assoc-set! cache (cons ta (map car functions)) text))
72                     text))))
73         (if (= ta 0) text
74             (let loop ((f functions))
75               (if (null? f) '()
76                   (append ((function->text functions globals ta t d) (car f))
77                           (loop (cdr f))))))))))
78
79 (define (function->text functions globals ta t d)
80   (lambda (o)
81     (let ((text (apply append (cdr o)))
82           (offset (function-offset (car o) functions)))
83       (let loop ((text text) (off offset))
84         (if (null? text) '()
85             (let ((label (car text)))
86               (if (number? label) (cons label (loop (cdr text) (1+ off)))
87                   (if (and (pair? label) (member (car label) '(#:comment #:label))) (loop (cdr text) off)
88                       (let* ((prefix (cond ((and (pair? (cdr text))
89                                                  (pair? (cddr text))
90                                                  (boolean? (caddr text))) 4)
91                                            ((and (pair? (cdr text))
92                                                  (boolean? (cadr text))) 2)
93                                            (else 1)))
94                              ;; (foo (format (current-error-port) "LABEL=~s\n" label))
95                              ;; (foo (format (current-error-port) "  prefix=~s\n" prefix))
96                              (address? (and (pair? label) (eq? (car label) #:address)))
97                              (local? (and (pair? label) (eq? (car label) #:local)))
98                              (relative? (and (pair? label) (eq? (car label) #:relative)))
99                              (label (if (or address? local? relative?) (cadr label) label))
100                              (function-address (function-offset label functions))
101                              (data-address (data-offset label globals))
102                              (label-address (label-offset (car o) `((#:label ,label)) functions))
103                              ;; (foo (format (current-error-port) "  address?=~s\n" address?))
104                              ;; (foo (format (current-error-port) "  d=~s\n" data-address))
105                              ;; (foo (format (current-error-port) "  f=~s\n" function-address))
106                              ;; (foo (format (current-error-port) "  l=~s\n" label-address))
107                              (address (or (and local?
108                                                (and=> label-address (lambda (a) (- a (- off offset) prefix))))
109                                           (and=> data-address (lambda (a) (+ a d)))
110                                           (if address?
111                                               (and=> function-address (lambda (a) (+ a ta)))
112                                               (and=> function-address (lambda (a) (- a off prefix))))
113                                           (error "unresolved label: " label))))
114                         (append ((case prefix ((1) list) ((2) int->bv16) ((4) int->bv32)) address)
115                                 (loop (list-tail text prefix) (+ off prefix))))))))))))
116
117 (define (function-prefix name functions)
118   ;; FIXME
119   ;;(member name (reverse functions) (lambda (a b) (equal? (car b) name)))
120   (let* ((x functions)
121          (x (if (and (pair? x) (equal? (caar x) "_start")) (reverse x) x)))
122     (member name x (lambda (a b) (equal? (car b) name)))))
123
124 (define function-offset
125   (let ((cache '()))
126     (lambda (name functions)
127       (or (assoc-ref cache name)
128           (let* ((functions (if (and (pair? functions) (equal? (caar functions) "_start")) functions (reverse functions)))
129                  (prefix (and=> (function-prefix name functions) cdr))
130                  (offset (and prefix
131                               (if (null? prefix) 0
132                                   (+ (length (functions->text (list (car prefix)) '() 0 0 0))
133                                      (if (null? (cdr prefix)) 0
134                                          (function-offset (caar prefix) functions)))))))
135             (if (and offset (or (equal? name "_start") (> offset 0))) (set! cache (assoc-set! cache name offset)))
136             offset)))))
137
138 (define label-offset
139   (let ((cache '()))
140     (lambda (function label functions)
141       (or (assoc-ref cache (cons function label))
142           (let ((prefix (function-prefix function functions)))
143             (if (not prefix) 0
144                 (let* ((function-entry (car prefix))
145                        (offset (let loop ((text (cdr function-entry)))
146                                  ;; FIXME: unresolved label
147                                  ;;(if (null? text) (error "unresolved label:"))
148                                  (if (or (null? text) (equal? (car text) label)) 0
149                                      (let* ((t (car text))
150                                             (n (if (and (pair? (car t))
151                                                         (member (caar t) '(#:label #:comment))) 0 (length t))))
152                                        (+ (loop (cdr text)) n))))))
153                   (when (> offset 0)
154                     (set! cache (assoc-set! cache (cons function label) offset)))
155                   offset)))))))
156
157 (define (globals->data functions globals t d)
158   (let loop ((text (append-map cdr globals)))
159     (if (null? text) '()
160         (let ((label (car text)))
161           (if (or (char? label) (number? label)) (cons label (loop (cdr text)))
162               (let* ((prefix (if (and (pair? (cdr text))
163                                       (pair? (cddr text))
164                                       (boolean? (caddr text))) 4
165                                       2))
166                      (function-address (function-offset label functions))
167                      (data-address (data-offset label globals))
168                      (address (or (and=> data-address (lambda (a) (+ a d)))
169                                   (and=> function-address (lambda (a) (+ a t)))
170                                   (error "unresolved label: " label))))
171                       (append ((if (= prefix 2) int->bv16 int->bv32) address)
172                               (loop (list-tail text prefix)))))))))
173
174 (define (simple-globals->data globals)
175   (append-map cdr globals))
176
177 (define data-offset
178   (let ((cache '()))
179     (lambda (name globals)
180       (or (assoc-ref cache name)
181           (let ((prefix (member name (reverse globals)
182                                 (lambda (a b)
183                                   (equal? (car b) name)))))
184             (and prefix
185                  (let ((offset (length (simple-globals->data (cdr prefix)))))
186                    (set! cache (assoc-set! cache name offset))
187                    offset)))))))