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 | |
---|