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