source: trunk/source/library/mach-o.lisp @ 9054

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

Very much a work in progress, and the idea may not get very far.

File size: 12.6 KB
Line 
1(in-package "CCL")
2
3
4
5
6;;; String tables: used both for symbol names and for section names.
7(defstruct mach-o-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 Mach-O symbols.
12(defstruct mach-o-symbol-table
13  (strings (make-mach-o-string-table))
14  data                                  ; foreign pointer
15  nsyms
16  )
17
18;;; Wrapper around libmach-o's "mach-o" pointer
19(defstruct elf-object
20  libelf-pointer
21  fd
22  pathname
23  )
24
25
26
27
28;;; Prepate to create an MACH-O object file at PATHNAME, overwriting
29;;; whatever might have been there.
30(defun create-mach-o-object (pathname)
31  (let* ((namestring (native-translated-namestring pathname))
32         (fd (ccl::fd-open namestring
33                           (logior #$O_RDWR #$O_CREAT #$O_TRUNC)
34                           #o755)))
35    (if (< fd 0)
36      (signal-file-error fd pathname)
37      (progn
38        (check-libmach-o-version)
39        (let* ((ptr (#_mach-o_begin fd #$MACH-O_C_WRITE +null-ptr+)))
40          (if (%null-ptr-p ptr)
41            (error "Can't initialize libmach-o object for ~s: ~a"
42                   pathname (libmach-o-error-string))
43            (make-mach-o-object :libmach-o-pointer (assert-pointer-type ptr :<E>lf)
44                             :fd fd
45                             :pathname pathname)))))))
46
47(defun mach-o-end (object)
48  (#_mach-o_end (mach-o-object-libelf-pointer object))
49  (setf (elf-object-libelf-pointer object) nil
50        (elf-object-fd object) nil))
51
52(defun new-elf-file-header (object format type machine)
53  (let* ((ehdr (#_elf64_newehdr (elf-object-libelf-pointer object))))
54    (if (%null-ptr-p ehdr)
55      (error "Can't create ELF file header for ~s: ~a"
56             (elf-object-pathname object)
57             (libelf-error-string))
58      (progn
59        (setf (paref (pref ehdr :<E>lf64_<E>hdr.e_ident) (:* :unsigned-char) #$EI_DATA) format
60              (pref ehdr :<E>lf64_<E>hdr.e_machine) machine
61              (pref ehdr :<E>lf64_<E>hdr.e_type) type
62              (pref ehdr :<E>lf64_<E>hdr.e_version) *checked-libelf-version*)
63        (assert-pointer-type ehdr :<E>lf64_<E>hdr)))))
64
65(defun new-elf-program-header (object &optional (count 1))
66  (let* ((phdr (#_elf64_newphdr (elf-object-libelf-pointer object) count)))
67    (if (%null-ptr-p phdr)
68      (error "Can't create ELF program header for ~s: ~a"
69             (elf-object-pathname object)
70             (libelf-error-string))
71      (assert-pointer-type phdr :<E>lf64_<P>hdr))))
72
73(defun new-elf-section (object)
74  (let* ((scn (#_elf_newscn (elf-object-libelf-pointer object))))
75    (if (%null-ptr-p scn)
76      (error "Can' create ELF section for ~s: ~a"
77             (elf-object-pathname object)
78             (libelf-error-string))
79      (assert-pointer-type scn :<E>lf_<S>cn))))
80
81(defun elf-section-header-for-section (object section)
82  (let* ((shdr (#_elf64_getshdr section)))
83    (if (%null-ptr-p shdr)
84      (error "Can' obtain ELF section header for ~s: ~a"
85             (elf-object-pathname object)
86             (libelf-error-string))
87      (assert-pointer-type shdr :<E>lf64_<S>hdr))))
88
89(defun elf-data-pointer-for-section (object section)
90  (let* ((data (#_elf_newdata section)))
91    (if (%null-ptr-p data)
92      (error "Can' obtain ELF data pointer for ~s: ~a"
93             (elf-object-pathname object)
94             (libelf-error-string))
95      (assert-pointer-type data :<E>lf_<D>ata))))
96                   
97
98(defun elf-register-string (string table)
99  (let* ((hash (elf-string-table-hash table))
100         (s (elf-string-table-string table)))
101    (when (gethash string hash)
102      (format t "~& duplicate: ~s" string))
103    (or (gethash string hash)
104        (setf (gethash string hash)
105              (let* ((n (length s)))
106                (dotimes (i (length string) (progn (vector-push-extend 0 s) n))
107                  (let* ((code (char-code (char string i))))
108                    (declare (type (mod #x110000 code)))
109                    (if (> code 255)
110                      (vector-push-extend (char-code #\sub) s)
111                      (vector-push-extend code s)))))))))
112
113
114(defun elf-lisp-function-name (f)
115  (let* ((name (format nil "~s" f)))
116    (subseq (nsubstitute #\0 #\# (nsubstitute #\. #\Space name)) 1)))
117
118(defx86lapfunction dynamic-dnode ((x arg_z))
119  (movq (% x) (% imm0))
120  (ref-global x86::heap-start arg_y)
121  (subq (% arg_y) (% imm0))
122  (shrq ($ x8664::dnode-shift) (% imm0))
123  (box-fixnum imm0 arg_z)
124  (single-value-return))
125
126(defun collect-elf-static-functions ()
127  (collect ((functions))
128    (freeze)
129    (block walk
130      (let* ((frozen-dnodes (frozen-space-dnodes)))
131        (%map-areas (lambda (o)
132                      (when (>= (dynamic-dnode o) frozen-dnodes)
133                        (return-from walk nil))
134                      (when (typep o 'function-vector)
135                        (functions (function-vector-to-function o))))
136                    ccl::area-dynamic
137                    ccl::area-dynamic
138                    )))
139    (functions)))
140
141(defun register-elf-functions (section-number)
142  (let* ((functions (collect-elf-static-functions))
143         (n (length functions))
144         (data (#_calloc (1+ n) (record-length :<E>lf64_<S>ym)))
145         (string-table (make-elf-string-table)))
146    (declare (fixnum n))
147    (do* ((i 0 (1+ i))
148          (p (%inc-ptr data (record-length :<E>lf64_<S>ym)) (progn (%incf-ptr p (record-length :<E>lf64_<S>ym)) p))
149          (f (pop functions) (pop functions)))
150         ((= i n)
151          (make-elf-symbol-table :strings string-table :data data :nsyms n))
152      (declare (fixnum i))
153      (setf (pref p :<E>lf64_<S>ym.st_name) (elf-register-string (elf-lisp-function-name f) string-table)
154            (pref p :<E>lf64_<S>ym.st_info) (logior (ash #$STB_GLOBAL 4) #$STT_FUNC)
155            (pref p :<E>lf64_<S>ym.st_shndx) section-number
156            (pref p :<E>lf64_<S>ym.st_value) (%address-of f)
157            (pref p :<E>lf64_<S>ym.st_size) (1+ (ash (1- (%function-code-words f)) target::word-shift))))))
158
159(defun elf-section-index (section)
160  (#_elf_ndxscn section))
161
162(defun elf-set-shstrab-section (object scn)
163  #+freebsd-target
164  (#_elf_setshstrndx (elf-object-libelf-pointer object) (elf-section-index scn))
165  #-freebsd-target
166  (declare (ignore object scn)))
167
168
169(defun elf-init-section-data-from-string-table (object section string-table)
170  (let* ((strings-data (elf-data-pointer-for-section object section))
171         (s (elf-string-table-string string-table))
172         (bytes (array-data-and-offset s))
173         (n (length s))
174         (buf (#_malloc n)))
175    (%copy-ivector-to-ptr bytes 0 buf 0 n)
176    (setf (pref strings-data :<E>lf_<D>ata.d_align) 1
177          (pref strings-data :<E>lf_<D>ata.d_off) 0
178          (pref strings-data :<E>lf_<D>ata.d_type) #$ELF_T_BYTE
179          (pref strings-data :<E>lf_<D>ata.d_version) #$EV_CURRENT
180          (pref strings-data :<E>lf_<D>ata.d_size) n
181          (pref strings-data :<E>lf_<D>ata.d_buf) buf)
182    n))
183
184(defun elf-init-symbol-section-from-symbol-table (object section symbols)
185  (let* ((symbols-data (elf-data-pointer-for-section object section))
186         (buf (elf-symbol-table-data symbols))
187         (nsyms (elf-symbol-table-nsyms symbols) )
188         (n (* (1+ nsyms) (record-length :<E>lf64_<S>ym))))
189    (setf (pref symbols-data :<E>lf_<D>ata.d_align) 8
190          (pref symbols-data :<E>lf_<D>ata.d_off) 0
191          (pref symbols-data :<E>lf_<D>ata.d_type) #$ELF_T_SYM
192          (pref symbols-data :<E>lf_<D>ata.d_version) #$EV_CURRENT
193          (pref symbols-data :<E>lf_<D>ata.d_size) n
194          (pref symbols-data :<E>lf_<D>ata.d_buf) buf)
195    nsyms))
196
197(defun elf-make-empty-data-for-section (object section &optional (size 0))
198  (let* ((data (elf-data-pointer-for-section object section))
199         (buf +null-ptr+))
200    (setf (pref data :<E>lf_<D>ata.d_align) 0
201          (pref data :<E>lf_<D>ata.d_off) 0
202          (pref data :<E>lf_<D>ata.d_type) #$ELF_T_BYTE
203          (pref data :<E>lf_<D>ata.d_version) #$EV_CURRENT
204          (pref data :<E>lf_<D>ata.d_size) size
205          (pref data :<E>lf_<D>ata.d_buf) buf)
206    0))
207 
208
209(defun elf-flag-phdr (object cmd flags)
210  (#_elf_flagphdr (elf-object-libelf-pointer object) cmd flags))
211
212(defun elf-update (object cmd)
213  (let* ((size (#_elf_update (elf-object-libelf-pointer object) cmd)))
214    (if (< size 0)
215      (error "elf_update failed for for ~s: ~a"
216             (elf-object-pathname object)
217             (libelf-error-string))
218      size)))
219
220(defun fixup-lisp-section-offset (fd eof sectnum)
221  (fd-lseek fd 0 #$SEEK_SET)
222  (rlet ((fhdr :<E>lf64_<E>hdr)
223         (shdr :<E>lf64_<S>hdr))
224    (fd-read fd fhdr (record-length :<E>lf64_<E>hdr))
225    (let* ((pos (+ (pref fhdr :<E>lf64_<E>hdr.e_shoff)
226                   (* sectnum (pref fhdr :<E>lf64_<E>hdr.e_shentsize)))))
227      (fd-lseek fd pos #$SEEK_SET)
228      (fd-read fd shdr (record-length :<E>lf64_<S>hdr))
229      (setf (pref shdr :<E>lf64_<S>hdr.sh_offset)
230            (+ #x2000 (logandc2 (+ eof 4095) 4095))) ; #x2000 for nilreg-area
231      (fd-lseek fd pos #$SEEK_SET)
232      (fd-write fd shdr (record-length :<E>lf64_<S>hdr))
233      t)))
234 
235(defun write-elf-symbols-to-file (pathname)
236  (let* ((object (create-elf-object pathname))
237         (file-header (new-elf-file-header object #$ELFDATA2LSB #$ET_DYN #$EM_X86_64))
238         (program-header (new-elf-program-header object))
239         (lisp-section (new-elf-section object))
240         (symbols-section (new-elf-section object))
241         (strings-section (new-elf-section object))
242         (shstrtab-section (new-elf-section object))
243         (section-names (make-elf-string-table))
244         (lisp-section-index (elf-section-index lisp-section))
245         (symbols (register-elf-functions lisp-section-index))
246         (lisp-section-header (elf-section-header-for-section object lisp-section))
247         (symbols-section-header (elf-section-header-for-section object symbols-section))
248         (strings-section-header (elf-section-header-for-section object strings-section))
249         (shstrtab-section-header (elf-section-header-for-section object shstrtab-section)))
250   
251    (setf (pref file-header :<E>lf64_<E>hdr.e_shstrndx) (elf-section-index shstrtab-section))
252    (setf (pref lisp-section-header :<E>lf64_<S>hdr.sh_name) (elf-register-string ".lisp" section-names)
253          (pref lisp-section-header :<E>lf64_<S>hdr.sh_type) #$SHT_NOBITS
254          (pref lisp-section-header :<E>lf64_<S>hdr.sh_flags) (logior #$SHF_WRITE #$SHF_ALLOC #$SHF_EXECINSTR)
255          (pref lisp-section-header :<E>lf64_<S>hdr.sh_addr) (ash (%get-kernel-global heap-start) target::fixnumshift)
256          (pref lisp-section-header :<E>lf64_<S>hdr.sh_size) (ash (frozen-space-dnodes) target::dnode-shift)
257          (pref lisp-section-header :<E>lf64_<S>hdr.sh_offset) 0
258          (pref lisp-section-header :<E>lf64_<S>hdr.sh_addralign) 1)
259    (setf (pref symbols-section-header :<E>lf64_<S>hdr.sh_name) (elf-register-string ".symtab" section-names)
260          (pref symbols-section-header :<E>lf64_<S>hdr.sh_type) #$SHT_SYMTAB
261          (pref symbols-section-header :<E>lf64_<S>hdr.sh_entsize) (record-length :<E>lf64_<S>ym)
262          (pref symbols-section-header :<E>lf64_<S>hdr.sh_link) (elf-section-index strings-section))
263    (setf (pref strings-section-header :<E>lf64_<S>hdr.sh_name) (elf-register-string ".strtab" section-names)
264          (pref strings-section-header :<E>lf64_<S>hdr.sh_type) #$SHT_STRTAB
265          (pref strings-section-header :<E>lf64_<S>hdr.sh_flags) (logior #$SHF_STRINGS #$SHF_ALLOC))
266    (setf (pref shstrtab-section-header :<E>lf64_<S>hdr.sh_name) (elf-register-string ".shstrtab" section-names)
267          (pref shstrtab-section-header :<E>lf64_<S>hdr.sh_type) #$SHT_STRTAB
268          (pref shstrtab-section-header :<E>lf64_<S>hdr.sh_flags) (logior #$SHF_STRINGS #$SHF_ALLOC))
269    (elf-make-empty-data-for-section object lisp-section (ash (frozen-space-dnodes) target::dnode-shift))
270    (elf-init-section-data-from-string-table object strings-section (elf-symbol-table-strings symbols))
271    (elf-init-section-data-from-string-table object shstrtab-section section-names)
272    (elf-init-symbol-section-from-symbol-table object symbols-section symbols)
273    ;; Prepare in-memory data structures.
274    (elf-update object #$ELF_C_NULL)
275    ;; Fix up the program header.
276    (setf (pref program-header :<E>lf64_<P>hdr.p_type) #$PT_PHDR
277          (pref program-header :<E>lf64_<P>hdr.p_offset) (pref file-header :<E>lf64_<E>hdr.e_phoff)
278          (pref program-header :<E>lf64_<P>hdr.p_filesz) (#_elf64_fsize #$ELF_T_PHDR 1 #$EV_CURRENT))
279    ;; Mark the program header as being dirty.
280    (elf-flag-phdr object #$ELF_C_SET #$ELF_F_DIRTY)
281    (let* ((eof (elf-update object #$ELF_C_WRITE))
282           (fd (elf-object-fd object)))
283      (elf-end object)
284      (fixup-lisp-section-offset fd eof lisp-section-index)
285      (fd-close fd))
286    pathname))
287
288     
289   
290   
Note: See TracBrowser for help on using the repository browser.