source: branches/working-0709/ccl/library/elf.lisp @ 7378

Last change on this file since 7378 was 7378, checked in by gb, 12 years ago

Get this working, at least well enough for our immediate purposes.

File size: 13.2 KB
Line 
1(in-package "CCL")
2
3(use-interface-dir :elf)
4
5
6;;; String tables: used both for symbol names and for section names.
7(defstruct elf-string-table
8  (hash (make-hash-table :test #'equal))
9  (string (make-array 100 :element-type '(unsigned-byte 8) :fill-pointer 1 :adjustable t)))
10
11;;; Collect info about Elf symbols.
12(defstruct elf-symbol-table
13  (strings (make-elf-string-table))
14  data                                  ; foreign pointer
15  nsyms
16  )
17
18;;; Wrapper around libelf's "elf" pointer
19(defstruct elf-object
20  libelf-pointer
21  fd
22  pathname
23  )
24
25
26;;; Is libelf thread-safe ?  Who knows, there's no
27;;; documentation ...
28(defun libelf-error-string (&optional (errnum -1))
29  (let* ((p (#_elf_errmsg errnum)))
30    (if (%null-ptr-p p)
31      (format nil "ELF error ~d" errnum)
32      (%get-cstring p))))
33
34(defloadvar *checked-libelf-version* nil)
35
36(defun check-libelf-version ()
37  (or *checked-libelf-version*
38      (progn
39        (open-shared-library "libelf.so")
40        (let* ((version (#_elf_version #$EV_CURRENT)))
41          (if (eql #$EV_NONE version)
42            (error "ELF library initialization failed: ~a" (libelf-error-string)))
43          (setq *checked-libelf-version* version)))))
44
45
46;;; Prepate to create an ELF object file at PATHNAME, overwriting
47;;; whatever might have been there.
48(defun create-elf-object (pathname)
49  (let* ((namestring (native-translated-namestring pathname))
50         (fd (ccl::fd-open namestring
51                           (logior #$O_RDWR #$O_CREAT #$O_TRUNC)
52                           #o755)))
53    (if (< fd 0)
54      (signal-file-error fd pathname)
55      (progn
56        (check-libelf-version)
57        (let* ((ptr (#_elf_begin fd #$ELF_C_WRITE +null-ptr+)))
58          (if (%null-ptr-p ptr)
59            (error "Can't initialize libelf object for ~s: ~a"
60                   pathname (libelf-error-string))
61            (make-elf-object :libelf-pointer (assert-pointer-type ptr :<E>lf)
62                             :fd fd
63                             :pathname pathname)))))))
64
65(defun elf-end (object)
66  (#_elf_end (elf-object-libelf-pointer object))
67  (setf (elf-object-libelf-pointer object) nil
68        (elf-object-fd object) nil))
69
70(defun new-elf-file-header (object format type machine)
71  (let* ((ehdr (#_elf64_newehdr (elf-object-libelf-pointer object))))
72    (if (%null-ptr-p ehdr)
73      (error "Can't create ELF file header for ~s: ~a"
74             (elf-object-pathname object)
75             (libelf-error-string))
76      (progn
77        (setf (paref (pref ehdr :<E>lf64_<E>hdr.e_ident) (:* :unsigned-char) #$EI_DATA) format
78              (pref ehdr :<E>lf64_<E>hdr.e_machine) machine
79              (pref ehdr :<E>lf64_<E>hdr.e_type) type
80              (pref ehdr :<E>lf64_<E>hdr.e_version) *checked-libelf-version*)
81        (assert-pointer-type ehdr :<E>lf64_<E>hdr)))))
82
83(defun new-elf-program-header (object &optional (count 1))
84  (let* ((phdr (#_elf64_newphdr (elf-object-libelf-pointer object) count)))
85    (if (%null-ptr-p phdr)
86      (error "Can't create ELF program header for ~s: ~a"
87             (elf-object-pathname object)
88             (libelf-error-string))
89      (assert-pointer-type phdr :<E>lf64_<P>hdr))))
90
91(defun new-elf-section (object)
92  (let* ((scn (#_elf_newscn (elf-object-libelf-pointer object))))
93    (if (%null-ptr-p scn)
94      (error "Can' create ELF section for ~s: ~a"
95             (elf-object-pathname object)
96             (libelf-error-string))
97      (assert-pointer-type scn :<E>lf_<S>cn))))
98
99(defun elf-section-header-for-section (object section)
100  (let* ((shdr (#_elf64_getshdr section)))
101    (if (%null-ptr-p shdr)
102      (error "Can' obtain ELF section header for ~s: ~a"
103             (elf-object-pathname object)
104             (libelf-error-string))
105      (assert-pointer-type shdr :<E>lf64_<S>hdr))))
106
107(defun elf-data-pointer-for-section (object section)
108  (let* ((data (#_elf_newdata section)))
109    (if (%null-ptr-p data)
110      (error "Can' obtain ELF data pointer for ~s: ~a"
111             (elf-object-pathname object)
112             (libelf-error-string))
113      (assert-pointer-type data :<E>lf_<D>ata))))
114                   
115
116(defun elf-register-string (string table)
117  (let* ((hash (elf-string-table-hash table))
118         (s (elf-string-table-string table)))
119    (when (gethash string hash)
120      (format t "~& duplicate: ~s" string))
121    (or (gethash string hash)
122        (setf (gethash string hash)
123              (let* ((n (length s)))
124                (dotimes (i (length string) (progn (vector-push-extend 0 s) n))
125                  (let* ((code (char-code (char string i))))
126                    (declare (type (mod #x110000 code)))
127                    (if (> code 255)
128                      (vector-push-extend (char-code #\sub) s)
129                      (vector-push-extend code s)))))))))
130
131
132(defun elf-lisp-function-name (f)
133  (let* ((name (format nil "~s" f)))
134    (subseq (nsubstitute #\0 #\# (nsubstitute #\. #\Space name)) 1)))
135
136(defx86lapfunction dynamic-dnode ((x arg_z))
137  (movq (% x) (% imm0))
138  (ref-global x86::heap-start arg_y)
139  (subq (% arg_y) (% imm0))
140  (shrq ($ x8664::dnode-shift) (% imm0))
141  (box-fixnum imm0 arg_z)
142  (single-value-return))
143
144(defun collect-elf-static-functions ()
145  (collect ((functions))
146    (freeze)
147    (block walk
148      (let* ((frozen-dnodes (frozen-space-dnodes)))
149        (%map-areas (lambda (o)
150                      (when (>= (dynamic-dnode o) frozen-dnodes)
151                        (return-from walk nil))
152                      (when (typep o 'function-vector)
153                        (functions (function-vector-to-function o))))
154                    ccl::area-dynamic
155                    ccl::area-dynamic
156                    )))
157    (functions)))
158
159(defun register-elf-functions (section-number)
160  (let* ((functions (collect-elf-static-functions))
161         (n (length functions))
162         (data (#_calloc (1+ n) (record-length :<E>lf64_<S>ym)))
163         (string-table (make-elf-string-table)))
164    (declare (fixnum n))
165    (do* ((i 0 (1+ i))
166          (p (%inc-ptr data (record-length :<E>lf64_<S>ym)) (progn (%incf-ptr p (record-length :<E>lf64_<S>ym)) p))
167          (f (pop functions) (pop functions)))
168         ((= i n)
169          (make-elf-symbol-table :strings string-table :data data :nsyms n))
170      (declare (fixnum n))
171      (setf (pref p :<E>lf64_<S>ym.st_name) (elf-register-string (elf-lisp-function-name f) string-table)
172            (pref p :<E>lf64_<S>ym.st_info) (logior (ash #$STB_GLOBAL 4) #$STT_FUNC)
173            (pref p :<E>lf64_<S>ym.st_shndx) section-number
174            (pref p :<E>lf64_<S>ym.st_value) (%address-of f)
175            (pref p :<E>lf64_<S>ym.st_size) (1+ (ash (1- (%function-code-words f)) target::word-shift))))))
176
177(defun elf-section-index (section)
178  (#_elf_ndxscn section))
179
180(defun elf-set-shstrab-section (object scn)
181  #+freebsd-target
182  (#_elf_setshstrndx (elf-object-libelf-pointer object) (elf-section-index scn))
183  #-freebsd-target
184  (declare (ignore object scn)))
185
186
187(defun elf-init-section-data-from-string-table (object section string-table)
188  (let* ((strings-data (elf-data-pointer-for-section object section))
189         (s (elf-string-table-string string-table))
190         (bytes (array-data-and-offset s))
191         (n (length s))
192         (buf (#_malloc n)))
193    (%copy-ivector-to-ptr bytes 0 buf 0 n)
194    (setf (pref strings-data :<E>lf_<D>ata.d_align) 1
195          (pref strings-data :<E>lf_<D>ata.d_off) 0
196          (pref strings-data :<E>lf_<D>ata.d_type) #$ELF_T_BYTE
197          (pref strings-data :<E>lf_<D>ata.d_version) #$EV_CURRENT
198          (pref strings-data :<E>lf_<D>ata.d_size) n
199          (pref strings-data :<E>lf_<D>ata.d_buf) buf)
200    n))
201
202(defun elf-init-symbol-section-from-symbol-table (object section symbols)
203  (let* ((symbols-data (elf-data-pointer-for-section object section))
204         (buf (elf-symbol-table-data symbols))
205         (nsyms (elf-symbol-table-nsyms symbols) )
206         (n (* (1+ nsyms) (record-length :<E>lf64_<S>ym))))
207    (setf (pref symbols-data :<E>lf_<D>ata.d_align) 8
208          (pref symbols-data :<E>lf_<D>ata.d_off) 0
209          (pref symbols-data :<E>lf_<D>ata.d_type) #$ELF_T_SYM
210          (pref symbols-data :<E>lf_<D>ata.d_version) #$EV_CURRENT
211          (pref symbols-data :<E>lf_<D>ata.d_size) n
212          (pref symbols-data :<E>lf_<D>ata.d_buf) buf)
213    nsyms))
214
215(defun elf-make-empty-data-for-section (object section &optional (size 0))
216  (let* ((data (elf-data-pointer-for-section object section))
217         (buf +null-ptr+))
218    (setf (pref data :<E>lf_<D>ata.d_align) 0
219          (pref data :<E>lf_<D>ata.d_off) 0
220          (pref data :<E>lf_<D>ata.d_type) #$ELF_T_BYTE
221          (pref data :<E>lf_<D>ata.d_version) #$EV_CURRENT
222          (pref data :<E>lf_<D>ata.d_size) size
223          (pref data :<E>lf_<D>ata.d_buf) buf)
224    0))
225 
226
227(defun elf-flag-phdr (object cmd flags)
228  (#_elf_flagphdr (elf-object-libelf-pointer object) cmd flags))
229
230(defun elf-update (object cmd)
231  (let* ((size (#_elf_update (elf-object-libelf-pointer object) cmd)))
232    (if (< size 0)
233      (error "elf_update failed for for ~s: ~a"
234             (elf-object-pathname object)
235             (libelf-error-string))
236      size)))
237
238(defun fixup-lisp-section-offset (fd eof sectnum)
239  (fd-lseek fd 0 #$SEEK_SET)
240  (rlet ((fhdr :<E>lf64_<E>hdr)
241         (shdr :<E>lf64_<S>hdr))
242    (fd-read fd fhdr (record-length :<E>lf64_<E>hdr))
243    (let* ((pos (+ (pref fhdr :<E>lf64_<E>hdr.e_shoff)
244                   (* sectnum (pref fhdr :<E>lf64_<E>hdr.e_shentsize)))))
245      (fd-lseek fd pos #$SEEK_SET)
246      (fd-read fd shdr (record-length :<E>lf64_<S>hdr))
247      (setf (pref shdr :<E>lf64_<S>hdr.sh_offset)
248            (+ #x2000 (logandc2 (+ eof 4095) 4095))) ; #x2000 for nilreg-area
249      (fd-lseek fd pos #$SEEK_SET)
250      (fd-write fd shdr (record-length :<E>lf64_<S>hdr))
251      t)))
252 
253(defun write-elf-symbols-to-file (pathname)
254  (let* ((object (create-elf-object pathname))
255         (file-header (new-elf-file-header object #$ELFDATA2LSB #$ET_DYN #$EM_X86_64))
256         (program-header (new-elf-program-header object))
257         (lisp-section (new-elf-section object))
258         (symbols-section (new-elf-section object))
259         (strings-section (new-elf-section object))
260         (shstrtab-section (new-elf-section object))
261         (section-names (make-elf-string-table))
262         (lisp-section-index (elf-section-index lisp-section))
263         (symbols (register-elf-functions lisp-section-index))
264         (lisp-section-header (elf-section-header-for-section object lisp-section))
265         (symbols-section-header (elf-section-header-for-section object symbols-section))
266         (strings-section-header (elf-section-header-for-section object strings-section))
267         (shstrtab-section-header (elf-section-header-for-section object shstrtab-section)))
268   
269    (setf (pref file-header :<E>lf64_<E>hdr.e_shstrndx) (elf-section-index shstrtab-section))
270    (setf (pref lisp-section-header :<E>lf64_<S>hdr.sh_name) (elf-register-string ".lisp" section-names)
271          (pref lisp-section-header :<E>lf64_<S>hdr.sh_type) #$SHT_NOBITS
272          (pref lisp-section-header :<E>lf64_<S>hdr.sh_flags) (logior #$SHF_WRITE #$SHF_ALLOC #$SHF_EXECINSTR)
273          (pref lisp-section-header :<E>lf64_<S>hdr.sh_addr) (ash (%get-kernel-global heap-start) target::fixnumshift)
274          (pref lisp-section-header :<E>lf64_<S>hdr.sh_size) (ash (frozen-space-dnodes) target::dnode-shift)
275          (pref lisp-section-header :<E>lf64_<S>hdr.sh_offset) 0
276          (pref lisp-section-header :<E>lf64_<S>hdr.sh_addralign) 1)
277    (setf (pref symbols-section-header :<E>lf64_<S>hdr.sh_name) (elf-register-string ".symtab" section-names)
278          (pref symbols-section-header :<E>lf64_<S>hdr.sh_type) #$SHT_SYMTAB
279          (pref symbols-section-header :<E>lf64_<S>hdr.sh_entsize) (record-length :<E>lf64_<S>ym)
280          (pref symbols-section-header :<E>lf64_<S>hdr.sh_link) (elf-section-index strings-section))
281    (setf (pref strings-section-header :<E>lf64_<S>hdr.sh_name) (elf-register-string ".strtab" section-names)
282          (pref strings-section-header :<E>lf64_<S>hdr.sh_type) #$SHT_STRTAB
283          (pref strings-section-header :<E>lf64_<S>hdr.sh_flags) (logior #$SHF_STRINGS #$SHF_ALLOC))
284    (setf (pref shstrtab-section-header :<E>lf64_<S>hdr.sh_name) (elf-register-string ".shstrtab" section-names)
285          (pref shstrtab-section-header :<E>lf64_<S>hdr.sh_type) #$SHT_STRTAB
286          (pref shstrtab-section-header :<E>lf64_<S>hdr.sh_flags) (logior #$SHF_STRINGS #$SHF_ALLOC))
287    (elf-make-empty-data-for-section object lisp-section (ash (frozen-space-dnodes) target::dnode-shift))
288    (elf-init-section-data-from-string-table object strings-section (elf-symbol-table-strings symbols))
289    (elf-init-section-data-from-string-table object shstrtab-section section-names)
290    (elf-init-symbol-section-from-symbol-table object symbols-section symbols)
291    ;; Prepare in-memory data structures.
292    (elf-update object #$ELF_C_NULL)
293    ;; Fix up the program header.
294    (setf (pref program-header :<E>lf64_<P>hdr.p_type) #$PT_PHDR
295          (pref program-header :<E>lf64_<P>hdr.p_offset) (pref file-header :<E>lf64_<E>hdr.e_phoff)
296          (pref program-header :<E>lf64_<P>hdr.p_filesz) (#_elf64_fsize #$ELF_T_PHDR 1 #$EV_CURRENT))
297    ;; Mark the program header as being dirty.
298    (elf-flag-phdr object #$ELF_C_SET #$ELF_F_DIRTY)
299    (let* ((eof (elf-update object #$ELF_C_WRITE))
300           (fd (elf-object-fd object)))
301      (elf-end object)
302      (fixup-lisp-section-offset fd eof lisp-section-index)
303      (fd-close fd))
304    pathname))
305
306     
307   
308   
Note: See TracBrowser for help on using the repository browser.