source: trunk/source/objc-bridge/process-objc-modules.lisp @ 13537

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

Update copyright notices.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 8.5 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2003-2009 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19(#-(or apple-objc gnu-objc)
20   (eval-when (:compile-toplevel :load-toplevel :execute)
21     #+darwinppc-target (pushnew :apple-objc *features*)
22     #+linuxppc-target (pushnew :gnu-objc *features*)
23     #-(or darwinppc-target linuxppc-target)
24     (error "Not sure what ObjC runtime system to use.")))
25
26#+apple-objc
27(progn
28(defvar *objc-module-verbose* nil)
29
30
31(defun process-section-in-all-libraries (segname sectionname function)
32  "For every loaded shared library, find the section named SECTIONNAME
33in the segment named SEGNAME.  If this section exists, call FUNCTION with
34a pointer to the section data and the section's size in bytes as arguments."
35  (with-cstrs ((seg segname)
36               (sect sectionname))
37    (rlet ((size :unsigned))
38      (with-macptrs (mach-header sectdata)
39        (dotimes (i (#_ _dyld_image_count))
40          (%setf-macptr mach-header (#_ _dyld_get_image_header i))
41          ;; Paranoia: this should never be null
42          (unless (%null-ptr-p mach-header)
43            ;; The one instance of an MH_BUNDLE I've encountered
44            ;; hasn't had its section data relocated.  I'm not sure
45            ;; if that's generally true of MH_BUNDLEs; for the time
46            ;; being, ignore them and concentrate on MH_DYLIBs.
47            (when (eql (pref mach-header :mach_header.filetype) #$MH_DYLIB)
48              (%setf-macptr sectdata (#_getsectdatafromheader
49                                      mach-header
50                                      seg
51                                      sect
52                                      size))
53              ;; This pointer may be null, unless the shared object
54              ;; file denoted by "mach_header" contains a segment and
55              ;; section matching those we're looking for.
56              (unless (%null-ptr-p sectdata)
57                (funcall function sectdata (pref size :unsigned))))))))))
58
59(defun process-objc-modules (f)
60  (process-section-in-all-libraries #$SEG_OBJC #$SECT_OBJC_MODULES f))
61
62;;; A not-too-interesting test of the mechanism.
63(defun show-objc-module-sections ()
64  (process-objc-modules #'(lambda (sect size)
65                            (format t "~& module section @~s, size = ~d"
66                                    sect size))))
67
68(defun process-module-classes (module classfn)
69  (when *objc-module-verbose*
70    (format t "~& processing classes in module ~s" module)
71    (force-output t)) 
72  (with-macptrs ((symtab (pref module :objc_module.symtab)))
73    (with-macptrs ((defsptr (pref symtab :objc_symtab.defs))
74                   (classptr))
75      (dotimes (i (pref symtab :objc_symtab.cls_def_cnt))
76        (%setf-macptr classptr (%get-ptr defsptr (* i (record-length :address))))
77        (when *objc-module-verbose*
78          (format t "~& processing class ~a, info = #x~8,'0x"
79                  (%get-cstring (pref classptr :objc_class.name))
80                  (pref classptr :objc_class.info))
81          (force-output t))
82        ;; process the class
83        (funcall classfn classptr)
84        ;; process the metaclass
85        (funcall classfn (pref classptr :objc_class.isa))))))
86
87(defun process-module-categories (module catfn)
88  (with-macptrs ((symtab (pref module :objc_module.symtab)))
89    (with-macptrs ((catptr
90                    (%inc-ptr (pref symtab :objc_symtab.defs)
91                              (* (pref symtab :objc_symtab.cls_def_cnt)
92                                 (record-length :address)))))
93      (dotimes (i (pref symtab :objc_symtab.cat_def_cnt))
94        (when *objc-module-verbose*
95          (format t "~& processing category ~s "
96                  (%get-cstring (pref (%get-ptr catptr)
97                                      :objc_category.category_name))))
98        (funcall catfn (%get-ptr catptr))
99        (%incf-ptr catptr (record-length :address))))))
100
101
102;;; This is roughly equivalent to the inner loop in DO-OBJC-METHODS.
103(defun process-methods-in-method-list (mlist class  mfun)
104  (unless (%null-ptr-p mlist)
105    (with-macptrs ((method (pref mlist :objc_method_list.method_list)))
106      (dotimes (i (pref mlist :objc_method_list.method_count))
107        (funcall mfun method class)
108        (%incf-ptr method (record-length :objc_method))))))
109
110;;; Categories push method lists onto the "front" of the class.
111;;; The methods that belong to the class are in the last method list,
112;;; so we skip everything else here.
113(defun process-class-methods (class methodfun)
114  (%stack-block ((iter 4))
115    (setf (%get-ptr iter) (%null-ptr))
116    (with-macptrs ((next)
117                   (mlist ))
118      (loop
119          (%setf-macptr next (#_class_nextMethodList class iter))
120          (when (%null-ptr-p next)
121            (process-methods-in-method-list mlist class  methodfun)
122            (return))
123        (%setf-macptr mlist next)))))
124
125(defun process-category-methods (category methodfun)
126  (with-macptrs ((classname (pref category :objc_category.class_name))
127                 (class (#_objc_lookUpClass classname))
128                 (metaclass (pref class :objc_class.isa))
129                 (instance-methods
130                  (pref category :objc_category.instance_methods))
131                 (class-methods
132                  (pref category :objc_category.class_methods)))
133    (process-methods-in-method-list instance-methods class methodfun)
134    (process-methods-in-method-list class-methods metaclass methodfun)))
135
136(defun process-module-methods (sectptr size methodfun)
137  "Process all modules in the ObjC module section SECTPTR, whose size
138in bytes is SIZE.  For each class and each category in each module,
139call METHODFUN on each method defined in a class or category.  The
140METHODFUN will be called with a stack-allocated/mutable pointer to the
141method, and a stack-allocated/mutable pointer to the method receiver's
142class or metaclass object."
143  (when *objc-module-verbose*
144    (format t "~& processing classes in section ~s" sectptr)
145    (force-output t))
146  (with-macptrs ((module sectptr))
147    (let* ((nmodules (/ size (record-length :objc_module))))
148      (dotimes (i nmodules)
149        (process-module-classes
150         module
151         #'(lambda (class)
152             (when *objc-module-verbose*
153               (format t "~& == processing class #x~8,'0x ~a, (#x~8,'0x) info = #x~8,'0x"
154                       (%ptr-to-int class)
155                       (%get-cstring (pref class :objc_class.name))
156                       (%ptr-to-int (pref class :objc_class.name))
157                       (pref class :objc_class.info)))
158             #+nope
159             (unless (logtest #$CLS_META (pref class :objc_class.info))
160               (map-objc-class class))
161             (process-class-methods class methodfun)))
162        (process-module-categories       
163         module
164         #'(lambda (category)
165             (process-category-methods category methodfun)))
166        (%incf-ptr module (record-length :objc_module))))))
167           
168(defun iterate-over-module-classes (sectptr size classfn)
169  (when *objc-module-verbose*
170    (format t "~& processing classes in section ~s" sectptr)
171    (force-output t))
172  (with-macptrs ((module sectptr))
173    (let* ((nmodules (/ size (record-length :objc_module))))
174      (dotimes (i nmodules)
175        (process-module-classes module classfn)
176        (%incf-ptr module (record-length :objc_module))))))
177
178         
179(defun process-section-methods (sectptr size methodfun &optional
180                                        (section-check-fun #'true))
181  "If SECTION-CHECK-FUN returns true when called with the (stack-allocated,
182mutable) Objc modules section SECTPTR, process all methods defined
183in all classes/categories in all modules in the section."
184  (when (funcall section-check-fun sectptr)
185    (process-module-methods sectptr size methodfun)))
186
187(defloadvar *sections-already-scanned-for-methods* ())
188
189(defun check-if-section-already-scanned (sectptr)
190  (unless (member sectptr *sections-already-scanned-for-methods*
191                  :test #'eql)
192    (push (%inc-ptr sectptr 0)          ;make a heap-allocated copy!
193          *sections-already-scanned-for-methods*)
194    t))
195
196(defun note-all-library-methods (method-function)
197  "For all methods defined in all classes and categories defined in all
198ObjC module sections in all loaded shared libraries, call METHOD-FUNCTION
199with the method and defining class as arguments.  (Both of these arguments
200may have been stack-allocated by the caller, and may be destructively
201modified by the caller after the METHOD-FUNCTION returns.)
202  Sections that have already been scanned in the current lisp session are
203ignored."
204  (process-objc-modules
205   #'(lambda (sectptr size)
206       (process-section-methods
207        sectptr
208        size
209        method-function
210        #'check-if-section-already-scanned))))
211
212
213                       
214
215)
216(provide "PROCESS-OBJC-MODULES") 
217
Note: See TracBrowser for help on using the repository browser.