source: trunk/source/library/mach-o-symbols.lisp @ 11462

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

Also work-in-progress, but at least it's the right file.

File size: 7.5 KB
Line 
1(in-package "CCL")
2
3;;; String tables: used both for symbol names and for section names.
4(defstruct mach-o-string-table
5  (hash (make-hash-table :test #'equal))
6  (string (make-array 100 :element-type '(unsigned-byte 8) :fill-pointer 1 :adjustable t)))
7
8;;; Collect info about Mach-O symbols.
9(defstruct mach-o-symbol-table
10  (strings (make-mach-o-string-table))
11  data                                  ; foreign pointer
12  nsyms
13  )
14
15(defun mach-o-lisp-function-name (f)
16  (let* ((name (format nil "~s" f)))
17    (subseq (nsubstitute #\0 #\# (nsubstitute #\. #\Space name)) 1)))
18
19(defun mach-o-register-string (string table)
20  (let* ((hash (mach-o-string-table-hash table))
21         (s (mach-o-string-table-string table)))
22    (when (gethash string hash)
23      (format t "~& duplicate: ~s" string))
24    (or (gethash string hash)
25        (setf (gethash string hash)
26              (let* ((n (length s)))
27                (dotimes (i (length string) (progn (vector-push-extend 0 s) n))
28                  (let* ((code (char-code (char string i))))
29                    (declare (type (mod #x110000 code)))
30                    (if (> code 255)
31                      (vector-push-extend (char-code #\sub) s)
32                      (vector-push-extend code s)))))))))
33
34(defun readonly-area-bounds ()
35  (ccl::do-gc-areas (a)
36    (when (eql (ccl::%fixnum-ref a target::area.code)
37               ccl::area-readonly)
38      (return
39        (values (ash (ccl::%fixnum-ref a target::area.low) target::fixnumshift)
40                (ash (ccl::%fixnum-ref a target::area.active) target::fixnumshift))))))
41
42#+ppc-target
43(defun collect-mach-o-static-functions ()
44  (purify)
45  (multiple-value-bind (readonly-low readonly-high)
46      (readonly-area-bounds)
47    (let* ((hash (make-hash-table :test #'eq)))
48      (ccl::%map-lfuns #'(lambda (f)
49                           (let* ((code-vector (ccl:uvref f 0))
50                                  (startaddr (+ (ccl::%address-of code-vector)
51                                                target::misc-data-offset)))
52                             (when (and (>= startaddr readonly-low)
53                                        (< startaddr readonly-high))
54                               (push f (gethash code-vector hash))))))
55      (collect ((functions))
56        (maphash #'(lambda (k v)
57                     (declare (ignore k))
58                     (if (null (cdr v))
59                       (functions (car v))))
60                 hash)
61        (values (sort (functions)
62                      #'(lambda (x y)
63                          (< (ccl::%address-of  (uvref x 0))
64                             (ccl::%address-of  (uvref y 0)))))
65                readonly-low
66                (- readonly-high readonly-low))))))
67
68(defun register-mach-o-functions (functions section-number)
69  (let* ((n (length functions))
70         (nlist-len #+64-bit-target (record-length :nlist_64)
71                    #+32-bit-target (record-length :nlist))
72         (data (#_calloc n nlist-len))
73         (string-table (make-mach-o-string-table)))
74    (declare (fixnum n))
75    (do* ((i 0 (1+ i))
76          (p (%inc-ptr data 0) (progn (%incf-ptr p nlist-len) p))
77          (f (pop functions) (pop functions)))
78         ((= i n)
79          (make-mach-o-symbol-table :strings string-table :data data :nsyms n))
80      (declare (fixnum i))
81      (let* ((namidx (mach-o-register-string (mach-o-lisp-function-name f) string-table))
82             (value (%address-of #+ppc-target (uvref f 0) #-ppc-target g))
83             (type #$N_SECT))
84      #+32-bit-target
85      (setf (pref p :nlist.n_un.n_strx) namidx
86            (pref p :nlist.n_value) value
87            (pref p :nlist.n_type) type
88            (pref p :nlist.n_other) section-number)
89      #+64-bit-target
90      (setf (pref p :nlist_64.n_un.n_strx) namidx
91            (pref p :nlist_64.n_value) value
92            (pref p :nlist_64.n_type) type
93            (pref p :nlist_64.n_sect) section-number)))))
94
95(defun write-mach-o-symbol-info (fd symtab)
96  (let* ((symoff *host-page-size*)
97         (nsyms (mach-o-symbol-table-nsyms symtab))
98         (symsize (* nsyms (record-length #+64-bit-target :nlist_64
99                                                   #+32-bit-target :nlist)))
100         (stroff (+ symoff symsize))
101         (string (mach-o-string-table-string (mach-o-symbol-table-strings symtab)))
102         (strsize (length string))
103         (bytes (array-data-and-offset string))
104         (strbuf (#_malloc strsize)))
105    (%copy-ivector-to-ptr bytes 0 strbuf 0 strsize)
106    (fd-lseek fd symoff #$SEEK_SET)
107    (fd-write fd (mach-o-symbol-table-data symtab) symsize)
108    (fd-write fd strbuf strsize)
109    (values symoff nsyms stroff strsize)))
110
111(defun write-mach-o-load-commands (fd pos)
112  (multiple-value-bind (functions start length)
113      (collect-mach-o-static-functions)
114    (let* ((symbols (register-mach-o-functions functions 1)))
115      (multiple-value-bind (symoff nsyms stroff strsize)
116          (write-mach-o-symbol-info fd symbols)
117        (rlet ((symtab :symtab_command
118                 :cmd #$LC_SYMTAB
119                 :cmdsize (record-length :symtab_command)
120                 :symoff symoff
121                 :nsyms nsyms
122                 :stroff stroff
123                 :strsize strsize))
124          (let* ((segsize (record-length #+64-bit-target :segment_command_64
125                                         #+32-bit-target :segment_command))
126                 (sectsize (record-length #+64-bit-target :section_64
127                                         #+32-bit-target :section))
128                 (totalsize (+ segsize sectsize)))
129            (%stack-block ((segment totalsize :clear t))
130              (let* ((section (%inc-ptr segment segsize)))
131                #+64-bit-target
132                (progn
133                  (setf (pref segment :segment_command_64.cmd) #$LC_SEGMENT_64
134                        (pref segment :segment_command_64.cmdsize) totalsize)
135                  (%cstr-pointer #$SEG_DATA
136                                 (pref segment :segment_command_64.segname)
137                                 nil)
138                  (setf (pref segment :segment_command_64.vmaddr) start
139                        (pref segment :segment_command_64.vmsize) length
140                        (pref segment :segment_command_64.fileoff) 0
141                        (pref segment :segment_command_64.filesize) 0
142                        (pref segment :segment_command_64.maxprot) 0
143                        (pref segment :segment_command_64.initprot) 0
144                        (pref segment :segment_command_64.nsects) 1)
145                  (%cstr-pointer "__lisp" (pref section :section_64.sectname) nil)
146                  (%cstr-pointer #$SEG_DATA (pref section :section_64.segname) nil)
147                  (setf (pref section :section_64.addr) start
148                        (pref section :section_64.size) length
149                        (pref section :section_64.align) 12))
150                #+32-bit-target
151                (progn
152                  (setf (pref segment :segment_command.cmd) #$LC_SEGMENT
153                        (pref segment :segment_command.cmdsize) totalsize)
154                  (%cstr-pointer #$SEG_DATA
155                                 (pref segment :segment_command.segname)
156                                 nil)
157                  (setf (pref segment :segment_command.vmaddr) start
158                        (pref segment :segment_command.vmsize) length
159                        (pref segment :segment_command.fileoff) 0
160                        (pref segment :segment_command.filesize) 0
161                        (pref segment :segment_command.maxprot) 0
162                        (pref segment :segment_command.initprot) 0
163                        (pref segment :segment_command.nsects) 1)
164                  (%cstr-pointer "__lisp" (pref section :section.sectname) nil)
165                  (%cstr-pointer #$SEG_DATA (pref section :section.segname) nil)
166                  (setf (pref section :section.addr) start
167                        (pref section :section.size) length
168                        (pref section :section.align) 12))
169                (fd-lseek fd pos #$SEEK_SET)
170                (fd-write fd segment totalsize)
171                (fd-write fd symtab (record-length :symtab_command))
172                (values 2
173                        (+ totalsize (record-length :symtab_command)))))))))))
174
175   
176(defun write-mach-header (fd)
177  (let* ((n (record-length #+64-bit-target :mach_header_64
178                           #+32-bit-target :mach_header)))
179    (multiple-value-bind (ncmds cmd-size)
180        (write-mach-o-load-commands fd n)
181      (rlet ((header #+64-bit-target :mach_header_64 #+32-bit-target :mach_header
182                     :magic #+64-bit-target #$#$MH_MAGIC_64 #+32-bit-target #$MH_MAGIC
183                     :cputype (logior #+64-bit-target #$CPU_ARCH_ABI64
184                                      #+32-bit-target 0
185                                      #+ppc-target #$CPU_TYPE_POWERPC
186                                      #+x86-target #$CPU_TYPE_X86)
187                     :cpusubtype #+x86-target #$CPU_SUBTYPE_X86_ALL #+ppc-target #$CPU_SUBTYPE_POWERPC_ALL
188                     :filetype #$MH_BUNDLE
189                     :ncmds ncmds
190                     :sizeofcmds cmd-size
191                     :flags (logior #$MH_NOUNDEFS)))
192        (fd-lseek fd 0 #$SEEK_SET)
193        (let* ((res (fd-write fd header n)))
194          (unless (eql res n)
195            (%errno-disp res)))
196        (fd-close fd)))))
197           
198
199   
200                 
201 
202                 
Note: See TracBrowser for help on using the repository browser.