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

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

Elf-symbol/profiling changes. Work-in-progress.

File size: 8.0 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        (if (eql #$EV_NONE (#_elf_version #$EV_CURRENT))
41          (error "ELF library initialization failed: ~a" (libelf-error-string)))
42        (setq *checked-libelf-version* t))))
43
44
45;;; Prepate to create an ELF object file at PATHNAME, overwriting
46;;; whatever might have been there.
47(defun create-elf-object (pathname)
48  (let* ((namestring (native-translated-namestring pathname))
49         (fd (ccl::fd-open namestring
50                           (logior #$O_RDWR #$O_CREAT #$O_TRUNC)
51                           #o755)))
52    (if (< fd 0)
53      (signal-file-error fd pathname)
54      (progn
55        (check-libelf-version)
56        (let* ((ptr (#_elf_begin fd #$ELF_C_WRITE +null-ptr+)))
57          (if (%null-ptr-p ptr)
58            (error "Can't initialize libelf object for ~s: ~a"
59                   pathname (libelf-error-string))
60            (make-elf-object :libelf-pointer (assert-pointer-type ptr :<E>lf)
61                             :fd fd
62                             :pathname pathname)))))))
63
64(defun new-elf-file-header (object format type machine)
65  (let* ((ehdr (#_elf64_newehdr (elf-object-libelf-pointer object))))
66    (if (%null-ptr-p ehdr)
67      (error "Can't create ELF file header for ~s: ~a"
68             (elf-object-pathname object)
69             (libelf-error-string))
70      (progn
71        (setf (paref (pref ehdr :<E>lf64_<E>hdr.e_ident) (:* :unsigned-char) #$EI_DATA) format
72              (pref ehdr :<E>lf64_<E>hdr.e_machine) machine
73              (pref ehdr :<E>lf64_<E>hdr.e_type) type)
74        (assert-pointer-type ehdr :<E>lf64_<E>hdr)))))
75
76(defun new-elf-program-header (object &optional (count 1))
77  (let* ((phdr (#_elf64_newphdr (elf-object-libelf-pointer object) count)))
78    (if (%null-ptr-p phdr)
79      (error "Can't create ELF program header for ~s: ~a"
80             (elf-object-pathname object)
81             (libelf-error-string))
82      (assert-pointer-type phdr :<E>lf64_<P>hdr))))
83
84(defun new-elf-section (object)
85  (let* ((scn (#_elf_newscn object)))
86    (if (%null-ptr-p scn)
87      (error "Can' create ELF section for ~s: ~a"
88             (elf-object-pathname object)
89             (libelf-error-string))
90      (assert-pointer-type scn :<E>lf_<S>cn))))
91
92(defun elf-section-header-for-section (object section)
93  (let* ((shdr (#_elf64_getshdr section)))
94    (if (%null-ptr-p shdr)
95      (error "Can' obtain ELF section header for ~s: ~a"
96             (elf-object-pathname object)
97             (libelf-error-string))
98      (assert-pointer-type shdr :<E>lf64_<S>hdr))))
99
100(defun elf-data-pointer-for-secton (object section)
101  (let* ((data (#_elf_newdata section)))
102    (if (%null-ptr-p data)
103      (error "Can' obtain ELF data pointer for ~s: ~a"
104             (elf-object-pathname object)
105             (libelf-error-string))
106      (assert-pointer-type data :<E>lf_<D>ata))))
107
108
109 
110
111 
112                   
113                   
114
115(defun elf-register-string (string table)
116  (let* ((hash (elf-string-table-hash table))
117         (s (elf-string-table-string table)))
118    (when (gethash string hash)
119      (format t "~& duplicate: ~s" string))
120    (or (gethash string hash)
121        (setf (gethash string hash)
122              (let* ((n (length s)))
123                (dotimes (i (length string) (progn (vector-push-extend 0 s) n))
124                  (let* ((code (char-code (char string i))))
125                    (declare (type (mod #x110000 code)))
126                    (if (> code 255)
127                      (vector-push-extend (char-code #\sub) s)
128                      (vector-push-extend code s)))))))))
129
130
131(defun elf-lisp-function-name (f)
132  (let* ((name (format nil "~s" f)))
133    (subseq (nsubstitute #\0 #\# (nsubstitute #\. #\Space name)) 1)))
134
135(defx86lapfunction dynamic-dnode ((x arg_z))
136  (movq (% x) (% imm0))
137  (ref-global x86::heap-start arg_y)
138  (subq (% arg_y) (% imm0))
139  (shrq ($ x8664::dnode-shift) (% imm0))
140  (box-fixnum imm0 arg_z)
141  (single-value-return))
142
143(defun collect-elf-static-functions ()
144  (collect ((functions))
145    (freeze)
146    (block walk
147      (let* ((frozen-dnodes (frozen-space-dnodes)))
148        (%map-areas (lambda (o)
149                      (when (>= (dynamic-dnode o) frozen-dnodes)
150                        (return-from walk nil))
151                      (when (typep o 'function-vector)
152                        (functions (function-vector-to-function o))))
153                    ccl::area-dynamic
154                    ccl::area-dynamic
155                    )))
156    (functions)))
157
158(defun register-elf-functions (section-number)
159  (let* ((functions (collect-elf-static-functions))
160         (n (length functions))
161         (data (#_calloc n (record-length :<E>lf64_<S>ym)))
162         (string-table (make-elf-string-table)))
163    (declare (fixnum n))
164    (do* ((i 0 (1+ i))
165          (p (%inc-ptr data 0) (progn (%incf-ptr p (record-length :<E>lf64_<S>ym)) p))
166          (f (pop functions) (pop functions)))
167         ((= i n)
168          (make-elf-symbol-table :strings string-table :data data :nsyms n))
169      (declare (fixnum n))
170      (setf (pref p :<E>lf64_<S>ym.st_name) (elf-register-string (elf-lisp-function-name f) string-table)
171            (pref p :<E>lf64_<S>ym.st_info) (logior (ash #$STB_GLOBAL 4) #$STT_FUNC)
172            (pref p :<E>lf64_<S>ym.st_shndx) section-number
173            (pref p :<E>lf64_<S>ym.st_value) (%address-of f)
174            (pref p :<E>lf64_<S>ym.st_size) (1+ (ash (1- (%function-code-words f)) target::word-shift))))))
175
176(defun elf-section-index (section)
177  (#_elf_ndxscn section))
178
179   
180(defun write-elf-symbols-to-file (pathname)
181  (let* ((object (create-elf-object pathname))
182         (file-header (new-elf-file-header object #$ELFDATA2LSB #$ET_DYN #$EM_X86_64))
183         (program-header (new-elf-program-header object))
184         (lisp-section (new-elf-section object))
185         (symbols-section (new-elf-section object))
186         (strings-section (new-elf-section object))
187         (shstrtab (new-elf-section object))
188         (section-names (make-elf-string-table))
189         (symbols (register-elf-functions (elf-section-index lisp-section)))
190         (lisp-section-header (elf-section-header-for-section object lisp-section))
191         (symbols-section-header (elf-section-header-for-section object symbols-section))
192         (strings-section-header (elf-section-header-for-section object strings-section))
193         (shstrtab-header (elf-section-header-for-section object shstrtab)))
194    (setf (pref lisp-header :<E>lf64_<S>hdr.sh_name) (elf-register-string ".lisp" section-names)
195          (pref lisp-header :<E>lf64_<S>hdr.sh_type) #$SHT_NOBITS
196          (pref lisp-header :<E>lf64_<S>hdr.sh_flags) (logior #$SHF_WRITE #$SHF_ALLOC #$SHF_EXECINSTR)
197          (pref lisp-header :<E>lf64_<S>hdr.sh_addr) (ash (%get-kernel-global heap-start) target::fixnumshift)
198          (pref lisp-header :<E>lf64_<S>hdr.sh_size (ash (frozen-space-dnodes) target::dnode-shift))
199          (pref lisp-header :<E>lf64_<S>hdr.sh_offset) 0
200          (pref lisp-header :<E>lf64_<S>hdr.sh_addralign) 1)
201    (setf (pref symbol-header :<E>lf64_<S>hdr.sh_name) (elf-register-string ".symtab" section-names)
202          (pref symbol-header :<E>lf64_<S>hdr.sh_type) #$SHT_SYMTAB
203          (pref symbol-header :<E>lf64_<S>hdr.sh_size
204         
205   
206   
Note: See TracBrowser for help on using the repository browser.