source: trunk/source/library/elf.lisp @ 12262

Last change on this file since 12262 was 12262, checked in by gz, 11 years ago

Fix type declaration

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