mescc: Display sexps better.
[mes.git] / module / mes / elf.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 ;;; elf.mes - produce a i386 elf executable.
24
25 ;;; Code:
26
27 (cond-expand
28  (guile)
29  (mes
30   (mes-use-module (srfi srfi-1))
31   (mes-use-module (mes bytevectors))
32   (mes-use-module (mes elf-util))))
33
34 (define (int->bv32 value)
35   (let ((bv (make-bytevector 4)))
36     (bytevector-u32-native-set! bv 0 value)
37     bv))
38
39 (define (int->bv16 value)
40   (let ((bv (make-bytevector 2)))
41     (bytevector-u16-native-set! bv 0 value)
42     bv))
43
44 (define elf32-addr int->bv32)
45 (define elf32-half int->bv16)
46 (define elf32-off int->bv32)
47 (define elf32-word int->bv32)
48
49 (define (make-elf functions globals init)
50   (define vaddress #x08048000)
51
52   (define ei-magic `(#x7f ,@(string->list "ELF")))
53   (define ei-class '(#x01)) ;; 32 bit
54   (define ei-data '(#x01))  ;; little endian
55   (define ei-version '(#x01))
56   (define ei-osabi '(#x00))
57   (define ei-pad '(#x0 #x0 #x0 #x0 #x0 #x0 #x0 #x0))
58   (define e-ident
59     (append
60      ei-magic
61      ei-class
62      ei-data
63      ei-version
64      ei-osabi
65      ei-pad))
66
67   (define ET-EXEC 2)
68   (define EM-386 3)
69   (define EV-CURRENT 1)
70
71   (define p-filesz (elf32-word 0))
72   (define p-memsz (elf32-word 0))
73   (define PF-X 1)
74   (define PF-W 2)
75   (define PF-R 4)
76   (define p-flags (elf32-word (logior PF-X PF-W PF-R)))
77   (define p-align (elf32-word 1))
78
79   (define (program-header type offset text)
80     (append
81      (elf32-word type)
82      (elf32-off offset)
83      (elf32-addr (+ vaddress offset))
84      (elf32-addr (+ vaddress offset))
85      (elf32-word (length text))
86      (elf32-word (length text))
87      p-flags
88      p-align
89      ))
90
91   (define (section-header name type flags offset text sh-link sh-info sh-entsize)
92     (append
93      (elf32-word name)
94      (elf32-word type)
95      ;;;;(elf32-word 3) ;; write/alloc must for data hmm
96      (elf32-word flags)
97      (elf32-addr (+ vaddress offset))
98      (elf32-off offset) 
99      (elf32-word (length text))
100      (elf32-word sh-link)
101      (elf32-word sh-info)
102      (elf32-word 1)
103      (elf32-word sh-entsize)))
104
105
106   (define e-type (elf32-half ET-EXEC))
107   (define e-machine (elf32-half EM-386))
108   (define e-version (elf32-word EV-CURRENT))
109   (define e-entry (elf32-addr 0))
110   ;;(define e-entry (elf32-addr (+ vaddress text-offset)))
111   ;;(define e-phoff (elf32-off 0))
112   (define e-shoff (elf32-off 0))
113   (define e-flags (elf32-word 0))
114   ;;(define e-ehsize (elf32-half 0))
115   (define e-phentsize (elf32-half (length (program-header 0 0 '()))))
116   (define e-phnum (elf32-half 2)) ; text+data
117   (define e-shentsize (elf32-half (length (section-header 0 0 0 0 '() 0 0 0))))
118   (define e-shnum (elf32-half 7))       ; sections: 7
119   (define e-shstrndx (elf32-half 4))
120
121   (define (elf-header size entry sections)
122     (append
123      e-ident
124      e-type
125      e-machine
126      e-version
127      (elf32-addr (+ vaddress entry)) ;; e-entry
128      (elf32-off size)                ;; e-phoff
129      (elf32-off sections)            ;; e-shoff
130      e-flags
131      (elf32-half size) ;; e-ehsize
132      e-phentsize
133      e-phnum
134      e-shentsize
135      e-shnum
136      e-shstrndx
137      ))
138
139   (define elf-header-size
140     (length (elf-header 0 0 0)))
141
142   (define program-header-size
143     (* 2 (length (program-header 0 0 '()))))
144
145   (define text-offset
146     (+ elf-header-size program-header-size))
147
148   (define PT-LOAD 1)
149   (define (program-headers text data)
150     (append
151      (program-header PT-LOAD text-offset text)
152      (program-header PT-LOAD data-offset data)))
153
154   (define comment
155     (string->list
156      (string-append
157       "MES"
158       ;;"Mes -- Maxwell Equations of Software\n"
159       ;;"https://gitlab.com/janneke/mes"
160       )
161      ;; #x05 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x02 #x00 #x00 #x00
162      ;; #\i #\3 #\8 #\6 #x00 #x00 #x00 #x00
163      ))
164
165   (define shstr
166     `(
167       #x00                              ; 0
168       ,@(string->list ".text") #x00     ; 1
169       ,@(string->list ".data") #x00     ; 7
170       ,@(string->list ".comment") #x00     ; 13
171       ,@(string->list ".shstrtab") #x00 ; 22
172       ,@(string->list ".symtab") #x00  ; 32
173       ,@(string->list ".strtab") #x00   ; 40
174       ))
175
176   (define (str functions)
177     (cons
178      0
179      (append-map
180       (lambda (s) (append (string->list s) (list 0)))
181       (map car functions))))
182
183   (define text-length
184     (length (functions->text functions globals 0 0 0)))
185
186   (define data-offset
187     (+ text-offset text-length))
188
189   (define stt-func 2)
190   (define stt-global-func 18)
191   (define (symbol-table-entry st-name st-offset st-length st-info st-other st-shndx)
192     (append
193      (elf32-word st-name)
194      (elf32-addr st-offset)
195      (elf32-word st-length)
196      (list st-info)
197      (list st-other)
198      (elf32-half st-shndx)))
199
200   (define (sym functions globals)
201     (define (symbol->table-entry o)
202       (let* ((name (car o))
203              (offset (function-offset name functions))
204              (len (length (text->list (cddr o))))
205              (str (append-map (lambda (x) (cons 0 (string->list x))) (cdr (member name (reverse (map car functions))))))
206              (i (1+ (length str))))
207         (symbol-table-entry i (+ vaddress text-offset offset) len stt-func 0 1)))
208     (append
209      (symbol-table-entry 0 0 0 0 0 0)
210      (append-map symbol->table-entry functions)))
211
212   (define data-address (+ data-offset vaddress))
213   (define text-address (+ text-offset vaddress))
214
215   (define data-length
216     (length (globals->data globals)))
217
218   (define comment-length
219     (length comment))
220
221   (define comment-offset
222     (+ data-offset data-length))
223
224   (define shstr-offset
225     (+ comment-offset comment-length))
226
227   (define shstr-length
228     (length shstr))
229
230   (define sym-offset
231     (+ shstr-offset shstr-length))
232
233   (define SHT-PROGBITS 1)
234   (define SHT-SYMTAB 2)
235   (define SHT-STRTAB 3)
236   (define SHT-NOTE 7)
237
238   (define SHF-WRITE 1)
239   (define SHF-ALLOC 2)
240   (define SHF-EXEC 4)
241   (define SHF-STRINGS #x20)
242
243   (let* ((text (functions->text functions globals text-address 0 data-address))
244          (raw-data (globals->data globals))
245          (data (let loop ((data raw-data) (init init))
246                  (if (null? init) data
247                      (loop ((car init) functions globals text-address 0 data-address data) (cdr init)))))
248          (entry (+ text-offset (function-offset "_start" functions)))
249          (sym (sym functions globals))
250          (str (str functions)))
251
252     (define (section-headers)
253     (append
254      (section-header 0 0 0 0 '() 0 0 0)
255      (section-header 1 SHT-PROGBITS (logior SHF-ALLOC SHF-EXEC) text-offset text 0 0 0)
256      (section-header 7 SHT-PROGBITS (logior SHF-ALLOC SHF-WRITE) data-offset data 0 0 0)
257      (section-header 13 SHT-PROGBITS 0 comment-offset comment 0 0 0)
258      (section-header 22 SHT-STRTAB 0 shstr-offset shstr 0 0 0)
259      (section-header 32 SHT-SYMTAB 0 sym-offset sym 6 0 (length (symbol-table-entry 0 0 0 0 9 0)))
260      (section-header 40 SHT-STRTAB 0 str-offset str 0 0 0)))
261
262
263     (define sym-length
264       (length sym))
265     
266     (define str-offset
267       (+ sym-offset sym-length))
268     
269     (define str-length
270       (length str))
271
272     (define section-headers-offset
273       (+ str-offset str-length))
274
275     (format (current-error-port) "ELF text=~a\n" (map dec->hex text))
276     (if (< (length raw-data) 200)
277         (format (current-error-port) "ELF raw-data=~a\n" (map dec->hex raw-data)))
278     (if (< (length data) 200)
279         (format (current-error-port) "ELF data=~a\n" (map dec->hex data)))
280     (format (current-error-port) "text-offset=~a\n" text-offset)
281     (format (current-error-port) "data-offset=~a\n" data-offset)
282     (format (current-error-port) "_start=~a\n" (number->string entry 16))
283     (append
284      (elf-header elf-header-size entry section-headers-offset)
285      (program-headers text data)
286      text
287      data
288      comment
289      shstr
290      sym
291      str
292      (section-headers))))