source: trunk/source/objc-bridge/objc-support.lisp @ 11913

Last change on this file since 11913 was 11913, checked in by gb, 10 years ago

pmcl-kernel.c: don't define objc_personality_v0, since in the Wacky World
Of Mach-O this can have the effect of shadowing the real ObjC runtime symbol.

x86-spentry64.s: in ffcall_return_registers: after saving return registers
relative to %csave0, restore them from there (not from %csave3). Most
callers don't care (will just look at the register buffer that csave0
pointed to), but if we're returning/raising an ObjC exception we want to get
it from the right place.

In the ObjC exception gunk, reference the new 'lisp_objc_personality' via
a 64-bit absolute address. This seems to be OK with the Leopard linker;
we'll see about other versions.

objc-support.lisp: in SETUP-OBJC-EXCEPTION-GLOBALS, try to ensure that
this only happens once per session (since we're using a kludge to
detect whether or not indirection is necessary.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 19.7 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2
3(in-package "CCL")
4
5(eval-when (:compile-toplevel :load-toplevel :execute)
6  (require "BRIDGE"))
7
8(defun allocate-objc-object (class)
9  (#/alloc class))
10
11(defun conforms-to-protocol (thing protocol)
12  (#/conformsToProtocol: thing (objc-protocol-address protocol)))
13
14
15
16
17#+apple-objc
18(defun iterate-over-objc-classes (fn)
19  (let* ((n (#_objc_getClassList (%null-ptr) 0)))
20    (declare (fixnum n))
21    (%stack-block ((buffer (the fixnum (ash n target::word-shift))))
22      (#_objc_getClassList buffer n)
23      (do* ((i 0 (1+ i)))
24           ((= i n) (values))
25        (declare (fixnum i))
26        (funcall fn (paref buffer (:* :id) i))))))
27
28#+apple-objc
29(defun count-objc-classes ()
30  (#_objc_getClassList (%null-ptr) 0)) 
31
32#+gnu-objc
33(defun iterate-over-objc-classes (fn)
34  (rletZ ((enum-state :address))
35    (loop
36      (let* ((class (#_objc_next_class enum-state)))
37        (if (%null-ptr-p class)
38          (return)
39          (funcall fn class))))))
40
41#+gnu-objc
42(defun count-objc-classes ()
43  (let* ((n 0))
44    (declare (fixnum n))
45    (rletZ ((enum-state :address))
46      (if (%null-ptr-p (#_objc_next_class enum-state))
47        (return n)
48        (incf n)))))
49
50(defun %note-protocol (p)
51  (with-macptrs ((cname (objc-message-send p "name" :address)))
52    (let* ((namelen (%cstrlen cname))
53           (name (make-string namelen)))
54      (declare (dynamic-extent name))
55      (%str-from-ptr cname namelen name)
56      (let* ((proto (or (gethash name *objc-protocols*)
57                        (progn
58                          (setq name (subseq name 0))
59                          (setf (gethash name *objc-protocols*)
60                                (make-objc-protocol :name name))))))
61        (unless (objc-protocol-address proto)
62          (setf (objc-protocol-address proto) (%inc-ptr p 0)))
63        proto))))
64
65(defun note-class-protocols (class)
66  #-apple-objc-2.0
67  (do* ((protocols (pref class :objc_class.protocols)
68                   (pref protocols :objc_protocol_list.next)))
69       ((%null-ptr-p protocols))
70    (let* ((count (pref protocols :objc_protocol_list.count)))
71      (with-macptrs ((list (pref protocols :objc_protocol_list.list)))
72        (dotimes (i count)
73          (with-macptrs ((p (paref list (:* (:* (:struct :<P>rotocol))) i)))
74            (%note-protocol p))))))
75  #+apple-objc-2.0
76  (rlet ((p-out-count :int))
77    (with-macptrs ((protocols (#_class_copyProtocolList class p-out-count)))
78      (let* ((n (pref p-out-count :int)))
79        (dotimes (i n)
80          (with-macptrs ((p (paref protocols (:* (:* (:struct :<P>rotocol))) i)))
81            (%note-protocol p))))
82      (unless (%null-ptr-p protocols) (#_free protocols)))))
83           
84
85(defun map-objc-classes (&optional (lookup-in-database-p t))
86  (iterate-over-objc-classes
87   #'(lambda (class)
88       (note-class-protocols class)
89       (install-foreign-objc-class class lookup-in-database-p))))
90
91(let* ((nclasses 0)
92       (lock (make-lock)))
93  (declare (fixnum nclasses))
94  (defun maybe-map-objc-classes (&optional use-db)
95    (with-lock-grabbed (lock)
96      (let* ((new (count-objc-classes)))
97        (declare (fixnum new))
98        (unless (= nclasses new)
99          (setq nclasses new)
100          (map-objc-classes use-db))
101        t)))
102  (defun reset-objc-class-count ()
103    (with-lock-grabbed (lock)
104      (setq nclasses 0))))
105
106(register-objc-class-decls)
107(maybe-map-objc-classes t)
108(register-objc-init-messages)
109
110#+gnu-objc
111(defun iterate-over-class-methods (class method-function)
112  (do* ((mlist (pref class :objc_class.methods)
113               (pref mlist :objc_method_list.method_next)))
114       ((%null-ptr-p mlist))
115    (do* ((n (pref mlist :objc_method_list.method_count))
116          (i 0 (1+ i))
117          (method (pref mlist :objc_method_list.method_list)
118                  (%incf-ptr method (record-length :objc_method))))
119         ((= i n))
120      (declare (fixnum i n))
121      (funcall method-function method class))))
122
123#+gnu-objc
124(progn
125  ;; Er, um ... this needs lots-o-work.
126  (let* ((objc-class-count 0))
127    (defun reset-objc-class-count () (setq objc-class-count 0))
128    (defun note-all-library-methods (method-function)
129      (do* ((i objc-class-count (1+ i))
130            (class (id->objc-class i) (id->objc-class i)))
131           ((eq class 0))
132        (iterate-over-class-methods class method-function)
133        (iterate-over-class-methods (id->objc-metaclass i) method-function))))
134  (def-ccl-pointers revive-objc-classes ()
135    (reset-objc-class-count)))
136
137(defun retain-obcj-object (x)
138  (objc-message-send x "retain"))
139
140
141#+apple-objc-2.0
142(progn
143(defloadvar *objc-exception-globals-setup* nil) 
144(defun setup-objc-exception-globals ()
145  (flet ((set-global (offset name)
146           (let* ((p (%int-to-ptr (+ (target-nil-value) (%kernel-global-offset offset))))
147                  (q (%get-ptr p)))
148             (unless (%null-ptr-p q)
149               (setq p q))
150             (setf (%get-ptr p)
151                   (foreign-symbol-address name)))))
152    (unless *objc-exception-globals-setup*
153      (setq *objc-exception-globals-setup* t)
154      (set-global 'objc-2-personality "___objc_personality_v0")
155      (set-global 'objc-2-begin-catch "_objc_begin_catch")
156      (set-global 'objc-2-end-catch "_objc_end_catch")
157      (set-global 'unwind-resume "__Unwind_Resume"))))
158
159
160(def-ccl-pointers setup-objc-exception-handling ()
161  (setup-objc-exception-globals))
162
163)
164
165
166(defvar *condition-id-map* (make-id-map) "Map lisp conditions to small integers")
167
168;;; Encapsulate an NSException in a lisp condition.
169(define-condition ns-exception (error)
170  ((ns-exception :initarg :ns-exception :accessor ns-exception))
171  (:report (lambda (c s)
172             (format s "Objective-C runtime exception: ~&~a"
173                     (nsobject-description (ns-exception c))))))
174
175
176
177(defclass ns-lisp-exception (ns::ns-exception)
178    ((condition :initarg :condition :initform nil :reader ns-lisp-exception-condition))
179  (:metaclass ns::+ns-object))
180
181(objc:defmethod #/init ((self ns-lisp-exception))
182  (#/initWithName:reason:userInfo: self #@"lisp exception" #@"lisp exception" +null-ptr+))
183
184
185(defun recognize-objc-exception (x)
186  (if (typep x 'ns:ns-exception)
187    (ns-exception->lisp-condition x)))
188
189(pushnew 'recognize-objc-exception *foreign-error-condition-recognizers*)
190
191(defun %make-nsstring (string)
192  (with-encoded-cstrs :utf-8 ((s string))
193    (#/initWithUTF8String: (#/alloc ns:ns-string) s)))
194
195(defmacro with-autoreleased-nsstring ((nsstring lisp-string) &body body)
196  `(let* ((,nsstring (%make-nsstring ,lisp-string)))
197     (#/autorelease ,nsstring)
198     ,@body))
199
200(defmacro with-autoreleased-nsstrings (speclist &body body)
201  (with-specs-aux 'with-autoreleased-nsstring speclist body))
202
203(defun retain-objc-instance (instance)
204  (#/retain instance))
205
206;;; May have to create/release autorelease pools before the bridge
207;;; is fully reinitialized, so use low-level OBJC-MESSAGE-SEND
208;;; and @class.
209(defun create-autorelease-pool ()
210  (objc-message-send
211   (objc-message-send (@class "NSAutoreleasePool") "alloc") "init"))
212
213(defun release-autorelease-pool (p)
214  (objc-message-send p "release" :void))
215
216
217#-ascii-only
218(defun lisp-string-from-nsstring (nsstring)
219  ;; The NSData object created here is autoreleased.
220  (let* ((data (#/dataUsingEncoding:allowLossyConversion:
221                nsstring
222                #+little-endian-target #x9c000100
223                #+big-endian-target #x98000100
224                nil)))
225    (unless (%null-ptr-p data)
226      (let* ((nbytes (#/length data))
227             (string (make-string (ash nbytes -2))))
228        ;; BLT the 4-byte code-points from the NSData object
229        ;; to the string, return the string.
230        (%copy-ptr-to-ivector (#/bytes data) 0 string 0 nbytes)))))
231       
232
233
234#+ascii-only
235(defun lisp-string-from-nsstring (nsstring)
236  (with-macptrs (cstring)
237    (%setf-macptr cstring
238                  (#/cStringUsingEncoding: nsstring #$NSASCIIStringEncoding))
239    (unless (%null-ptr-p cstring)
240      (%get-cstring cstring))))
241
242
243(objc:defmethod #/reason ((self ns-lisp-exception))
244  (with-slots (condition) self
245    (if condition
246      (#/autorelease (%make-nsstring (format nil "~A" condition)))
247      (call-next-method))))
248
249(objc:defmethod #/description ((self ns-lisp-exception))
250  (#/stringWithFormat: ns:ns-string #@"Lisp exception: %@" (#/reason self)))
251
252
253                     
254(defun ns-exception->lisp-condition (nsexception)
255  (if (typep nsexception 'ns-lisp-exception)
256    (ns-lisp-exception-condition nsexception)
257    (make-condition 'ns-exception :ns-exception nsexception)))
258
259
260(defmethod ns-exception ((c condition))
261  "Map a lisp condition object to an NSException.  Note that instances
262of the NS-EXCEPTION condition class implement this by accessing an
263instance variable."
264  ;;; Create an NSLispException with a lispid that encapsulates
265  ;;; this condition.
266
267  ;; (dbg (format nil "~a" c))
268  ;;(#_NSLog #@"Lisp exception: %@" :id (%make-nsstring (format nil "~a" c)))
269  (make-instance 'ns-lisp-exception :condition c))
270
271
272
273#+apple-objc
274(progn
275
276
277#+ppc-target
278(defun objc-callback-error-return (condition return-value-pointer return-address-pointer)
279  ;; On PPC, the "address" of an external entry point is always
280  ;; aligned on a 32-bit word boundary.  On PPC32, it can always
281  ;; be represented as a fixnum; on PPC64, it might be a pointer
282  ;; instead.
283  ;; Note that this clobbers the actual (foreign) return address,
284  ;; replacing it with the address of #__NSRaiseError.  Note also
285  ;; that storing the NSException object as the return value has
286  ;; the desired effect of causing #__NSRaiseError to be called
287  ;; with that NSException as its argument (because r3 is used both
288  ;; as the canonical return value register and used to pass the
289  ;; first argument on PPC.)
290  (process-debug-condition *current-process* condition (%get-frame-ptr))
291  (let* ((addr (%reference-external-entry-point (load-time-value (external "__NSRaiseError")))))
292    (if (typep addr 'fixnum)
293      (%set-object return-address-pointer 0 addr)
294      (setf (%get-ptr return-address-pointer 0) addr)))
295  (setf (%get-ptr return-value-pointer 0) (ns-exception condition))
296  nil)
297
298#+x8664-target
299(progn
300(defloadvar *x8664-objc-callback-error-return-trampoline*
301    (let* ((code-bytes '(#x48 #x89 #xc7      ; movq %rax %rdi
302                         #x66 #x48 #x0f #x7e #xc0 ; movd %xmm0,%rax
303                         #x52                ; pushq %rdx
304                         #xff #xe0))         ; jmp *rax
305           (nbytes (length code-bytes))
306           (ptr (%allocate-callback-pointer 16)))
307      (dotimes (i nbytes ptr)
308        (setf (%get-unsigned-byte ptr i) (pop code-bytes)))))
309
310(defun objc-callback-error-return (condition return-value-pointer return-address-pointer) 
311  ;; The callback glue reserves space for %rax at return-value-pointer-8,
312  ;; for %rdx at -16, for %xmm0 at -24.  Store NS-EXCEPTION in the
313  ;; %rax slot, the address of #_objc_exception_throw in the %rdx slot, the
314  ;; original return address in the %xmm0 slot, and force a return to
315  ;; the trampoline code above.
316  (process-debug-condition *current-process* condition (%get-frame-ptr))
317  (setf (%get-ptr return-value-pointer -8) (ns-exception condition)
318        (%get-ptr return-value-pointer -16) (%get-ptr return-address-pointer 0)
319        (%get-ptr return-address-pointer 0) *x8664-objc-callback-error-return-trampoline*)
320  ;; A foreign entry point is always an integer on x8664.
321  (let* ((addr (%reference-external-entry-point (load-time-value (external "_objc_exception_throw")))))
322    (if (< addr 0)                      ;unlikely
323      (setf (%%get-signed-longlong return-value-pointer -24) addr)
324      (setf (%%get-unsigned-longlong return-value-pointer -24) addr)))
325  nil)
326
327
328)
329
330#+x8632-target
331(progn
332
333(defloadvar *x8632-objc-callback-error-return-trampoline*
334    (let* ((code-bytes '(#x83 #xec #x10      ; subl $16,%esp
335                         #x89 #x04 #x24      ; movl %eax,(%esp)
336                         #x52                ; pushl %edx
337                         #xff #xe1))         ; jmp *ecx
338           (nbytes (length code-bytes))
339           (ptr (%allocate-callback-pointer 16)))
340      (dotimes (i nbytes ptr)
341        (setf (%get-unsigned-byte ptr i) (pop code-bytes)))))
342
343(defun objc-callback-error-return (condition return-value-pointer return-address-pointer)
344  (process-debug-condition *current-process* condition (%get-frame-ptr))
345  (let* ((addr (%reference-external-entry-point (load-time-value (external "__NSRaiseError")))))
346    (setf (%get-unsigned-long return-value-pointer -12 ) addr))
347  (setf (%get-ptr return-value-pointer -8) (ns-exception condition)
348        (%get-ptr return-value-pointer -4) (%get-ptr return-address-pointer)
349        (%get-ptr return-address-pointer) *x8632-objc-callback-error-return-trampoline*)
350  nil)
351)
352
353)
354
355
356
357(defun open-main-bundle ()
358  (#/mainBundle ns:ns-bundle))
359
360;;; Create a new immutable dictionary just like src, replacing the
361;;; value of each key in key-value-pairs with the corresponding value.
362(defun copy-dictionary (src &rest key-value-pairs)
363  (declare (dynamic-extent key-value-pairs))
364  ;(#_NSLog #@"src = %@" :id src)
365  (let* ((count (#/count src))
366         (enum (#/keyEnumerator src))
367         (keys (#/arrayWithCapacity: ns:ns-mutable-array count))
368         (values (#/arrayWithCapacity: ns:ns-mutable-array count)))
369    (loop
370        (let* ((nextkey (#/nextObject enum)))
371          (when (%null-ptr-p nextkey)
372            (return))
373          (do* ((kvps key-value-pairs (cddr kvps))
374                (newkey (car kvps) (car kvps))
375                (newval (cadr kvps) (cadr kvps)))
376               ((null kvps)
377                ;; Copy the key, value pair from the src dict
378                (#/addObject: keys nextkey)
379                (#/addObject: values (#/objectForKey: src nextkey)))
380            (when (#/isEqualToString: nextkey newkey)
381              (#/addObject: keys nextkey)
382              (#/addObject: values newval)
383              (return)))))
384    (make-instance 'ns:ns-dictionary
385                   :with-objects values
386                   :for-keys keys)))
387
388
389(defun nsobject-description (nsobject)
390  "Returns a lisp string that describes nsobject.  Note that some
391NSObjects describe themselves in more detail than others."
392  (with-autorelease-pool
393      (lisp-string-from-nsstring  (#/description nsobject))))
394
395
396
397
398;;; This can fail if the nsstring contains non-8-bit characters.
399(defun lisp-string-from-nsstring-substring (nsstring start length)
400  (%stack-block ((cstring (1+ length)))
401    (#/getCString:maxLength:range:remainingRange:
402       nsstring  cstring  length (ns:make-ns-range start length) +null-ptr+)
403    (%get-cstring cstring)))
404
405(def-standard-initial-binding *listener-autorelease-pool* nil)
406
407(setq *listener-autorelease-pool* (create-autorelease-pool))
408
409(define-toplevel-command :global rap () "Release and reestablish *LISTENER-AUTORELEASE-POOL*"
410  (when (eql *break-level* 0)
411    (without-interrupts
412     (when (boundp '*listener-autorelease-pool*)
413       (let* ((old *listener-autorelease-pool*))
414         (if old (release-autorelease-pool old))
415         (setq *listener-autorelease-pool* (create-autorelease-pool)))))))
416
417#+apple-objc
418(defun show-autorelease-pools ()
419  (objc-message-send (@class ns-autorelease-pool) "showPools" :void))
420
421#+gnu-objc
422(defun show-autorelease-pools ()
423  (do* ((current (objc-message-send (@class ns-autorelease-pool) "currentPool")
424                 (objc-message-send current "_parentAutoreleasePool"))
425        (i 0 (1+ i)))
426       ((%null-ptr-p current) (values))
427    (format t "~& ~d : ~a [~d]"
428            i
429            (nsobject-description current)
430            (pref current :<NSA>utorelease<P>ool._released_count))))
431
432(define-toplevel-command :global sap () "Log information about current thread's autorelease-pool(s) to C's standard error stream"
433  (show-autorelease-pools))
434
435(define-toplevel-command :global kap () "Release (but don't reestablish) *LISTENER-AUTORELEASE-POOL*"
436  (when (eql *break-level* 0)
437    (without-interrupts
438     (when (boundp '*listener-autorelease-pool*)
439       (let* ((p *listener-autorelease-pool*))
440         (setq *listener-autorelease-pool* nil)
441         (release-autorelease-pool p))))))
442
443;;; Use the interfaces for an add-on ObjC framework.  We need to
444;;; tell the bridge to reconsider what it knows about the type
445;;; signatures of ObjC messages, since the new headers may define
446;;; a method whose type signature differs from the message's existing
447;;; methods.  (This probably doesn't happen too often, but it's
448;;; possible that some SENDs that have already been compiled would
449;;; need to be recompiled with that augmented method type info, e.g.,
450;;; because ambiguity was introduced.)
451
452(defun augment-objc-interfaces (dirname)
453  (use-interface-dir dirname)
454  (register-objc-class-decls)
455  (update-objc-method-info))
456
457;;; A list of "standard" locations which are known to contain
458;;; framework bundles.  We should look in ~/Library/Frameworks/" first,
459;;; if it exists.
460(defparameter *standard-framework-directories*
461  (list #p"/Library/Frameworks/"
462        #p"/System/Library/Frameworks/"))
463
464
465
466;;; This has to run during application (re-)initializtion, so it
467;;; uses lower-level bridge features.
468(defun %reload-objc-framework (path)
469  (when (probe-file path)
470    (let* ((namestring (native-translated-namestring path)))
471      (with-cstrs ((cnamestring namestring))
472        (with-nsstr (nsnamestring cnamestring (length namestring))
473          (with-autorelease-pool
474              (let* ((bundle (objc-message-send (@class "NSBundle")
475                                                "bundleWithPath:"
476                                                :id nsnamestring :id)))
477                (unless (%null-ptr-p bundle)
478                  (objc-message-send bundle "load" :<BOOL>)))))))))
479
480
481(defun load-objc-extension-framework (name)
482  (let* ((dirs *standard-framework-directories*)
483         (home-frameworks (make-pathname :defaults nil
484                                         :directory
485                                         (append (pathname-directory
486                                                  (user-homedir-pathname))
487                                                 '("Library" "Frameworks"))))
488         (fname (list (format nil "~a.framework" name))))
489    (when (probe-file home-frameworks)
490      (pushnew home-frameworks dirs :test #'equalp))
491    (dolist (d dirs)
492      (let* ((path (probe-file (make-pathname :defaults nil
493                                              :directory (append (pathname-directory d)
494                                                                 fname)))))
495        (when path
496          (let* ((namestring (native-translated-namestring path)))
497            (with-cstrs ((cnamestring namestring))
498              (with-nsstr (nsnamestring cnamestring (length namestring))
499                (with-autorelease-pool
500                    (let* ((bundle (#/bundleWithPath: ns:ns-bundle nsnamestring))
501                           (winning (unless (%null-ptr-p bundle)
502                                      t)))
503                      (when winning
504                        (let* ((libpath (#/executablePath bundle)))
505                          (unless (%null-ptr-p libpath)
506                            (open-shared-library (lisp-string-from-nsstring
507                                                  libpath))))
508                        (#/load bundle)
509                        (pushnew path *extension-framework-paths*
510                                 :test #'equalp)
511                        (map-objc-classes)
512                        ;; Update info about init messages.
513                        (register-objc-init-messages))
514                      (return winning)))))))))))
515
516(defun objc:load-framework (framework-name interfaces-name)
517  (use-interface-dir interfaces-name)
518  (or (load-objc-extension-framework framework-name)
519      (error "Can't load ObjC framework ~s" framework-name))
520  (augment-objc-interfaces interfaces-name))
521
522                     
523(defmethod print-object ((p ns:protocol) stream)
524  (print-unreadable-object (p stream :type t)
525    (format stream "~a (#x~x)"
526            (%get-cstring (#/name p))
527            (%ptr-to-int p))))
528
529                                         
530(defmethod terminate ((instance objc:objc-object))
531  (objc-message-send instance "release"))
532
533
534(provide "OBJC-SUPPORT")
Note: See TracBrowser for help on using the repository browser.