source: release/1.6/source/library/mach-o-symbols.lisp @ 14493

Last change on this file since 14493 was 13067, checked in by rme, 10 years ago

Update copyright notices.

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