source: branches/purify/source/library/elf.lisp @ 13256

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

We're going to want to use PURIFY rather than FREEZE here; more changes
will be necessary.

File size: 17.7 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
153
154(defun collect-elf-static-functions ()
155  (collect ((functions))
156    (purify)
157    (block walk
158      (let* ((frozen-dnodes (frozen-space-dnodes)))
159        (%map-areas (lambda (o)
160                      (when (typep o
161                                   #+x8664-target 'function-vector
162                                   #-x8664-target 'function)
163                        (functions (function-vector-to-function o))))
164                    ccl::area-readonly
165                    ccl::area-readonly
166                    )))
167    (functions)))
168
169(defun register-elf-functions (section-number)
170  (let* ((functions (collect-elf-static-functions))
171         (n (length functions))
172         (data (#_calloc (1+ n) (record-length #+64-bit-target :<E>lf64_<S>ym
173                                               #+32-bit-target :<E>lf32_<S>ym)))
174         (string-table (make-elf-string-table)))
175    (declare (fixnum n))
176    (do* ((i 0 (1+ i))
177          (p (%inc-ptr data
178                       (record-length #+64-bit-target :<E>lf64_<S>ym
179                                      #+32-bit-target :<E>lf32_<S>ym))
180             (progn (%incf-ptr p
181                               (record-length #+64-bit-target :<E>lf64_<S>ym
182                                              #+32-bit-target :<E>lf32_<S>ym))
183                    p))
184          (f (pop functions) (pop functions)))
185         ((= i n)
186          (make-elf-symbol-table :strings string-table :data data :nsyms n))
187      (declare (fixnum n))
188      (setf (pref p
189                  #+64-bit-target :<E>lf64_<S>ym.st_name
190                  #+32-bit-target :<E>lf32_<S>ym.st_name)
191            (elf-register-string (elf-lisp-function-name f) string-table)
192            (pref p
193                  #+64-bit-target :<E>lf64_<S>ym.st_info
194                  #+32-bit-target :<E>lf32_<S>ym.st_info)
195            (logior (ash #$STB_GLOBAL 4) #$STT_FUNC)
196            (pref p
197                  #+64-bit-target :<E>lf64_<S>ym.st_shndx
198                  #+32-bit-target :<E>lf32_<S>ym.st_shndx) section-number
199            (pref p
200                  #+64-bit-target :<E>lf64_<S>ym.st_value
201                  #+32-bit-target :<E>lf32_<S>ym.st_value) (%address-of f)
202            (pref p
203                  #+64-bit-target :<E>lf64_<S>ym.st_size
204                  #+32-bit-target :<E>lf32_<S>ym.st_size) (1+ (ash (1- (%function-code-words f)) target::word-shift))))))
205
206(defun elf-section-index (section)
207  (#_elf_ndxscn section))
208
209(defun elf-set-shstrab-section (object scn)
210  #+freebsd-target
211  (#_elf_setshstrndx (elf-object-libelf-pointer object) (elf-section-index scn))
212  #-freebsd-target
213  (declare (ignore object scn)))
214
215
216(defun elf-init-section-data-from-string-table (object section string-table)
217  (let* ((strings-data (elf-data-pointer-for-section object section))
218         (s (elf-string-table-string string-table))
219         (bytes (array-data-and-offset s))
220         (n (length s))
221         (buf (#_malloc n)))
222    (%copy-ivector-to-ptr bytes 0 buf 0 n)
223    (setf (pref strings-data :<E>lf_<D>ata.d_align) 1
224          (pref strings-data :<E>lf_<D>ata.d_off) 0
225          (pref strings-data :<E>lf_<D>ata.d_type) #$ELF_T_BYTE
226          (pref strings-data :<E>lf_<D>ata.d_version) #$EV_CURRENT
227          (pref strings-data :<E>lf_<D>ata.d_size) n
228          (pref strings-data :<E>lf_<D>ata.d_buf) buf)
229    n))
230
231(defun elf-init-symbol-section-from-symbol-table (object section symbols)
232  (let* ((symbols-data (elf-data-pointer-for-section object section))
233         (buf (elf-symbol-table-data symbols))
234         (nsyms (elf-symbol-table-nsyms symbols) )
235         (n (* (1+ nsyms) (record-length #+64-bit-target :<E>lf64_<S>ym
236                                         #+32-bit-target :<E>lf32_<S>ym))))
237    (setf (pref symbols-data :<E>lf_<D>ata.d_align) 8
238          (pref symbols-data :<E>lf_<D>ata.d_off) 0
239          (pref symbols-data :<E>lf_<D>ata.d_type) #$ELF_T_SYM
240          (pref symbols-data :<E>lf_<D>ata.d_version) #$EV_CURRENT
241          (pref symbols-data :<E>lf_<D>ata.d_size) n
242          (pref symbols-data :<E>lf_<D>ata.d_buf) buf)
243    nsyms))
244
245(defun elf-make-empty-data-for-section (object section &optional (size 0))
246  (let* ((data (elf-data-pointer-for-section object section))
247         (buf +null-ptr+))
248    (setf (pref data :<E>lf_<D>ata.d_align) 0
249          (pref data :<E>lf_<D>ata.d_off) 0
250          (pref data :<E>lf_<D>ata.d_type) #$ELF_T_BYTE
251          (pref data :<E>lf_<D>ata.d_version) #$EV_CURRENT
252          (pref data :<E>lf_<D>ata.d_size) size
253          (pref data :<E>lf_<D>ata.d_buf) buf)
254    0))
255 
256
257(defun elf-flag-phdr (object cmd flags)
258  (#_elf_flagphdr (elf-object-libelf-pointer object) cmd flags))
259
260(defun elf-update (object cmd)
261  (let* ((size (#_elf_update (elf-object-libelf-pointer object) cmd)))
262    (if (< size 0)
263      (error "elf_update failed for for ~s: ~a"
264             (elf-object-pathname object)
265             (libelf-error-string))
266      size)))
267
268(defun fixup-lisp-section-offset (fd eof sectnum)
269  (fd-lseek fd 0 #$SEEK_SET)
270  (rlet ((fhdr #+64-bit-target :<E>lf64_<E>hdr
271               #+32-bit-target :<E>lf32_<E>hdr)
272         (shdr #+64-bit-target :<E>lf64_<S>hdr
273               #+32-bit-target :<E>lf32_<S>hdr))
274    (fd-read fd fhdr (record-length #+64-bit-target :<E>lf64_<E>hdr
275                                    #+32-bit-target :<E>lf32_<E>hdr))
276    (let* ((pos (+ (pref fhdr #+64-bit-target :<E>lf64_<E>hdr.e_shoff
277                         #+32-bit-target :<E>lf32_<E>hdr.e_shoff)
278                   (* sectnum (pref fhdr #+64-bit-target :<E>lf64_<E>hdr.e_shentsize
279                                    #+32-bit-target :<E>lf32_<E>hdr.e_shentsize)))))
280      (fd-lseek fd pos #$SEEK_SET)
281      (fd-read fd shdr (record-length #+64-bit-target :<E>lf64_<S>hdr
282                                      #+32-bit-target :<E>lf32_<S>hdr))
283      (setf (pref shdr #+64-bit-target :<E>lf64_<S>hdr.sh_offset
284                  #+32-bit-target :<E>lf32_<S>hdr.sh_offset)
285            (+ #x2000 (logandc2 (+ eof 4095) 4095))) ; #x2000 for nilreg-area
286      (fd-lseek fd pos #$SEEK_SET)
287      (fd-write fd shdr (record-length #+64-bit-target :<E>lf64_<S>hdr
288                                       #+32-bit-target :<E>lf32_<S>hdr))
289      t)))
290 
291(defun write-elf-symbols-to-file (pathname)
292  (let* ((object (create-elf-object pathname))
293         (file-header (new-elf-file-header object
294                                           #+little-endian-target #$ELFDATA2LSB
295                                           #+big-endian-target #$ELFDATA2MSB
296                                           #$ET_DYN
297                                           #+x8664-target #$EM_X86_64
298                                           #+x8632-target #$EM_386
299                                           #+ppc32-target #$EM_PPC
300                                           #+ppc64-target #$EM_PPC64
301                                           ))
302         (program-header (new-elf-program-header object))
303         (lisp-section (new-elf-section object))
304         (symbols-section (new-elf-section object))
305         (strings-section (new-elf-section object))
306         (shstrtab-section (new-elf-section object))
307         (section-names (make-elf-string-table))
308         (lisp-section-index (elf-section-index lisp-section))
309         (symbols (register-elf-functions lisp-section-index))
310         (lisp-section-header (elf-section-header-for-section object lisp-section))
311         (symbols-section-header (elf-section-header-for-section object symbols-section))
312         (strings-section-header (elf-section-header-for-section object strings-section))
313         (shstrtab-section-header (elf-section-header-for-section object shstrtab-section)))
314   
315    (setf (pref file-header #+64-bit-target :<E>lf64_<E>hdr.e_shstrndx
316                #+32-bit-target :<E>lf32_<E>hdr.e_shstrndx) (elf-section-index shstrtab-section))
317    (setf (pref lisp-section-header #+64-bit-target :<E>lf64_<S>hdr.sh_name
318                #+32-bit-target :<E>lf32_<S>hdr.sh_name) (elf-register-string ".lisp" section-names)
319          (pref lisp-section-header #+64-bit-target :<E>lf64_<S>hdr.sh_type
320                #+32-bit-target :<E>lf32_<S>hdr.sh_type) #$SHT_NOBITS
321          (pref lisp-section-header #+64-bit-target :<E>lf64_<S>hdr.sh_flags
322                #+32-bit-target :<E>lf32_<S>hdr.sh_flags) (logior #$SHF_WRITE #$SHF_ALLOC #$SHF_EXECINSTR)
323          (pref lisp-section-header #+64-bit-target :<E>lf64_<S>hdr.sh_addr
324                #+32-bit-target :<E>lf32_<S>hdr.sh_addr) (ash (%get-kernel-global heap-start) target::fixnumshift)
325          (pref lisp-section-header #+64-bit-target :<E>lf64_<S>hdr.sh_size
326                #+32-bit-target :<E>lf32_<S>hdr.sh_size) (ash (frozen-space-dnodes) target::dnode-shift)
327          (pref lisp-section-header #+64-bit-target :<E>lf64_<S>hdr.sh_offset
328                #+32-bit-target :<E>lf32_<S>hdr.sh_offset) 0
329          (pref lisp-section-header #+64-bit-target :<E>lf64_<S>hdr.sh_addralign
330                #+32-bit-target :<E>lf32_<S>hdr.sh_addralign) 1)
331    (setf (pref symbols-section-header #+64-bit-target :<E>lf64_<S>hdr.sh_name
332                #+32-bit-target :<E>lf32_<S>hdr.sh_name) (elf-register-string ".symtab" section-names)
333          (pref symbols-section-header #+64-bit-target :<E>lf64_<S>hdr.sh_type
334                #+32-bit-target :<E>lf32_<S>hdr.sh_type) #$SHT_SYMTAB
335          (pref symbols-section-header #+64-bit-target :<E>lf64_<S>hdr.sh_entsize
336                #+32-bit-target :<E>lf32_<S>hdr.sh_entsize) (record-length #+64-bit-target :<E>lf64_<S>ym
337                                                                           #+32-bit-target :<E>lf32_<S>ym)
338          (pref symbols-section-header #+64-bit-target :<E>lf64_<S>hdr.sh_link
339                #+32-bit-target :<E>lf32_<S>hdr.sh_link) (elf-section-index strings-section))
340    (setf (pref strings-section-header #+64-bit-target :<E>lf64_<S>hdr.sh_name
341                #+32-bit-target :<E>lf32_<S>hdr.sh_name) (elf-register-string ".strtab" section-names)
342          (pref strings-section-header #+64-bit-target :<E>lf64_<S>hdr.sh_type
343                #+32-bit-target :<E>lf32_<S>hdr.sh_type) #$SHT_STRTAB
344          (pref strings-section-header #+64-bit-target :<E>lf64_<S>hdr.sh_flags
345                #+32-bit-target :<E>lf32_<S>hdr.sh_flags) (logior #$SHF_STRINGS #$SHF_ALLOC))
346    (setf (pref shstrtab-section-header #+64-bit-target :<E>lf64_<S>hdr.sh_name
347                #+32-bit-target :<E>lf32_<S>hdr.sh_name) (elf-register-string ".shstrtab" section-names)
348          (pref shstrtab-section-header #+64-bit-target :<E>lf64_<S>hdr.sh_type
349                #+32-bit-target :<E>lf32_<S>hdr.sh_type) #$SHT_STRTAB
350          (pref shstrtab-section-header #+64-bit-target :<E>lf64_<S>hdr.sh_flags
351                #+32-bit-target :<E>lf32_<S>hdr.sh_flags) (logior #$SHF_STRINGS #$SHF_ALLOC))
352    (elf-make-empty-data-for-section object lisp-section (ash (frozen-space-dnodes) target::dnode-shift))
353    (elf-init-section-data-from-string-table object strings-section (elf-symbol-table-strings symbols))
354    (elf-init-section-data-from-string-table object shstrtab-section section-names)
355    (elf-init-symbol-section-from-symbol-table object symbols-section symbols)
356    ;; Prepare in-memory data structures.
357    (elf-update object #$ELF_C_NULL)
358    ;; Fix up the program header.
359    (setf (pref program-header
360                #+64-bit-target :<E>lf64_<P>hdr.p_type
361                #+32-bit-target :<E>lf32_<P>hdr.p_type) #$PT_PHDR
362          (pref program-header #+64-bit-target :<E>lf64_<P>hdr.p_offset
363                #+32-bit-target :<E>lf32_<P>hdr.p_offset)
364          (pref file-header
365                #+64-bit-target :<E>lf64_<E>hdr.e_phoff
366                #+32-bit-target :<E>lf32_<E>hdr.e_phoff)
367          (pref program-header
368                #+64-bit-target :<E>lf64_<P>hdr.p_filesz
369                #+32-bit-target :<E>lf32_<P>hdr.p_filesz)
370          (#+64-bit-target #_elf64_fsize #+32-bit-target #_elf32_fsize #$ELF_T_PHDR 1 #$EV_CURRENT))
371    ;; Mark the program header as being dirty.
372    (elf-flag-phdr object #$ELF_C_SET #$ELF_F_DIRTY)
373    (let* ((eof (elf-update object #$ELF_C_WRITE))
374           (fd (elf-object-fd object)))
375      (elf-end object)
376      (fixup-lisp-section-offset fd eof lisp-section-index)
377      (fd-close fd))
378    pathname))
379
380     
381   
382   
Note: See TracBrowser for help on using the repository browser.