source: release/1.4/source/library/elf.lisp @ 13181

Last change on this file since 13181 was 13181, checked in by gb, 11 years ago

(in 1.4) In FIXUP-LISP-SECTION-HEADER-OFFSET, set the section header's
type to #$SHT_PROGBITS (fixes ticket:625).

While we're there, add an extra page to the calculated offset,
to account for the preceding image and section headers on 32-bit
platforms.

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