Index: /trunk/ccl/examples/objc-runtime.lisp =================================================================== --- /trunk/ccl/examples/objc-runtime.lisp (revision 5727) +++ /trunk/ccl/examples/objc-runtime.lisp (revision 5728) @@ -45,5 +45,4 @@ (progn (use-interface-dir :cocoa) - #-apple-objc-2.0 (use-interface-dir :carbon)) ; need :carbon for things in this file #+gnu-objc @@ -62,4 +61,15 @@ (defloadvar *NSApp* nil ) +;;; Apple ObjC 2.0 provides (#_objc_getProtocol name). In other +;;; runtimes, there doesn't seem to be any way to find a Protocol +;;; object given its name. We need to be able to ask at runtime +;;; whether a given object conforms to a protocol in order to +;;; know when a protocol method is ambiguous, at least when the +;;; message contains ambiguous methods and some methods are protocol +;;; methods +(defloadvar *objc-protocols* (make-hash-table :test #'equal)) + +(defun lookup-objc-protocol (name) + (values (gethash name *objc-protocols*))) (defun ensure-objc-classptr-resolved (classptr) @@ -68,4 +78,5 @@ (unless (logtest #$_CLS_RESOLV (pref classptr :objc_class.info)) (external-call "__objc_resolve_class_links" :void))) + @@ -451,6 +462,6 @@ #|(defconstant JMP-ctr #x5c "count register jmp_buf offset")|# (defconstant JMP-sp 0 "stack pointer offset in jmp_buf") -(defconstant JMP-r13 8 "offset of r13 (which we clobber) in jmp_buf") -(defconstant JMP-r14 12 "offset of r14 (which we also clobber) in jmp_buf")) +(defconstant JMP-r14 12 "offset of r14 (which we clobber) in jmp_buf") +(defconstant JMP-r15 16 "offset of r14 (which we also clobber) in jmp_buf")) #+ppc64-target @@ -459,14 +470,17 @@ #|(defconstant JMP-ctr #x5c "count register jmp_buf offset")|# (defconstant JMP-sp 0 "stack pointer offset in jmp_buf") -(defconstant JMP-r13 #x10 "offset of r13 (which we clobber) in jmp_buf") -(defconstant JMP-r14 #x18 "offset of r14 (which we also clobber) in jmp_buf")) +(defconstant JMP-r13 #x10 "offset of r13 (which we preserve) in jmp_buf") +(defconstant JMP-r14 #x18 "offset of r14 (which we clobber) in jmp_buf") +(defconstant JMP-r15 #x20 "offset of r15 (which we also clobber) in jmp_buf")) -;;; A malloc'ed pointer to two words of machine code. The first -;;; instruction (rather obviously) copies r13 to r4. A C function -;;; passes its second argument in r4, but since r4 isn't saved in a -;;; jmp_buf, we have to do this copy. The second instruction just -;;; jumps to the address in the count register, which is where we -;;; really wanted to go in the first place. +;;; A malloc'ed pointer to thre words of machine code. The first +;;; instruction copies the address of the trampoline callback from r14 +;;; to the count register. The second instruction (rather obviously) +;;; copies r15 to r4. A C function passes its second argument in r4, +;;; but since r4 isn't saved in a jmp_buf, we have to do this copy. +;;; The second instruction just jumps to the address in the count +;;; register, which is where we really wanted to go in the first +;;; place. (macrolet ((ppc-lap-word (instruction-form) @@ -475,9 +489,9 @@ (ppc-lap-function () ((?? 0)) ,instruction-form))) - 0) 0))) + 0) #+ppc64-target 1 #+ppc32-target 0))) (defloadvar *setjmp-catch-lr-code* (let* ((p (malloc 12))) (setf (%get-unsigned-long p 0) (ppc-lap-word (mtctr 14)) - (%get-unsigned-long p 4) (ppc-lap-word (mr 4 13)) + (%get-unsigned-long p 4) (ppc-lap-word (mr 4 15)) (%get-unsigned-long p 8) (ppc-lap-word (bctr))) ;;; Force this code out of the data cache and into memory, so @@ -499,9 +513,11 @@ ;;; wind up calling THROW-TO-CATCH-FRAME with the specified catch ;;; frame as its second argument. The C frame used here is just -;; an empty C stack frame from which the callback will be called. +;;; an empty C stack frame from which the callback will be called. (defun %associate-jmp-buf-with-catch-frame (jmp-buf catch-frame c-frame) (%set-object jmp-buf JMP-sp c-frame) - (%set-object jmp-buf JMP-r13 catch-frame) + (%set-object jmp-buf JMP-r15 catch-frame) + #+ppc64-target + (%set-object jmp-buf JMP-r13 (%get-os-context)) (setf (%get-ptr jmp-buf JMP-lr) *setjmp-catch-lr-code* (%get-ptr jmp-buf JMP-r14) throw-to-catch-frame) @@ -565,18 +581,15 @@ (meta-id (objc-class-id->objc-metaclass-id i)) (m (id->objc-metaclass meta-id))) + (let* ((class (make-objc-class-pair super (make-cstring (objc-class-id-foreign-name i)))) + (meta (pref class #+apple-objc :objc_class.isa + #+gnu-objc :objc-class.class_pointer))) (unless (splay-tree-get metaclass-map m) (%revive-macptr m) - (%setf-macptr m (%make-basic-meta-class - (make-cstring (objc-metaclass-id-foreign-name meta-id)) - super - (find-class 'ns::ns-object))) + (%setf-macptr m meta) (splay-tree-put metaclass-map m meta-id)) - (%setf-macptr c (%make-class-object - m - super - (make-cstring (objc-class-id-foreign-name i)) - (%null-ptr) - 0)) - + (%setf-macptr c class)) + #+apple-objc-2.0 + (%add-objc-class c) + #-apple-objc-2.0 (multiple-value-bind (ivars instance-size) (%make-objc-ivars c) @@ -1226,5 +1239,5 @@ (%get-signed-long method-vector 12) -1) method-vector)) - + ;;; Make a meta-class object (with no instance variables or class @@ -1407,4 +1420,7 @@ (#___objc_exec_class m))) +#+apple-objc-2.0 +(defun %add-objc-class (class) + (#_objc_registerClassPair class)) (defun %make-nsstring (string) @@ -1435,15 +1451,5 @@ -#+apple-objc -(defun zone-pointer-size (p) - (with-macptrs ((zone (#_malloc_zone_from_ptr p))) - (unless (%null-ptr-p zone) - (let* ((size (ff-call (pref zone :malloc_zone_t.size) - :address zone - :address p - :int))) - (declare (fixnum size)) - (unless (zerop size) - size))))) + (defun objc-private-class-id (classptr) @@ -1451,5 +1457,6 @@ (when info (or (private-objc-class-info-declared-ancestor info) - (with-macptrs ((super (pref classptr :objc_class.super_class))) + (with-macptrs ((super #+apple-objc-2.0 (#_class_getSuperclass classptr) + #-apple-objc-2.0 (pref classptr :objc_class.super_class))) (loop (when (%null-ptr-p super) @@ -1459,5 +1466,6 @@ (return (setf (private-objc-class-info-declared-ancestor info) id)) - (%setf-macptr super (pref super :objc_class.super_class)))))))))) + (%setf-macptr super #+apple-objc-2.0 (#_class_getSuperclass super) + #-apple-objc-2.0 (pref super :objc_class.super_class)))))))))) (defun objc-class-or-private-class-id (classptr) @@ -1467,12 +1475,13 @@ (defun %objc-instance-class-index (p) - (if (with-macptrs (q) - (safe-get-ptr p q) - (not (%null-ptr-p q))) - (with-macptrs ((parent #+apple-objc (pref p :objc_object.isa) - #+gnu-objc (pref p :objc_object.class_pointer))) - (or - (objc-class-id parent) - (objc-private-class-id parent))))) + (unless (%null-ptr-p p) + (if (with-macptrs (q) + (safe-get-ptr p q) + (not (%null-ptr-p q))) + (with-macptrs ((parent #+apple-objc (pref p :objc_object.isa) + #+gnu-objc (pref p :objc_object.class_pointer))) + (or + (objc-class-id parent) + (objc-private-class-id parent)))))) @@ -1535,31 +1544,42 @@ (defun %add-objc-method (classptr selector typestring imp) - #+apple-objc - (#_class_addMethods classptr - (%mlist-containing classptr selector typestring imp)) - #+gnu-objc + #+apple-objc-2.0 + (with-cstrs ((typestring typestring)) + (or (not (eql #$NO (#_class_addMethod classptr selector imp typestring))) + (let* ((m (if (objc-metaclass-p classptr) + (#_class_getClassMethod classptr selector) + (#_class_getInstanceMethod classptr selector)))) + (if (not (%null-ptr-p m)) + (#_method_setImplementation m imp) + (error "Can't add ~s method to class ~s" selector typestring))))) + #-apple-objc-2.0 + (progn + #+apple-objc + (#_class_addMethods classptr + (%mlist-containing classptr selector typestring imp)) + #+gnu-objc ;;; We have to do this ourselves, and have to do it with the runtime ;;; mutex held. - (with-gnu-objc-mutex-locked (*gnu-objc-runtime-mutex*) - (let* ((ctypestring (make-cstring typestring)) - (new-mlist nil)) - (with-macptrs ((method (external-call "search_for_method_in_list" - :address (pref classptr :objc_class.methods) - :address selector - :address))) - (when (%null-ptr-p method) - (setq new-mlist (make-record :objc_method_list :method_count 1)) - (%setf-macptr method (pref new-mlist :objc_method_list.method_list))) - (setf (pref method :objc_method.method_name) selector - (pref method :objc_method.method_types) ctypestring - (pref method :objc_method.method_imp) imp) - (if new-mlist - (external-call "GSObjCAddMethods" - :address classptr - :address new-mlist - :void) - (external-call "__objc_update_dispatch_table_for_class" - :address classptr - :void)))))) + (with-gnu-objc-mutex-locked (*gnu-objc-runtime-mutex*) + (let* ((ctypestring (make-cstring typestring)) + (new-mlist nil)) + (with-macptrs ((method (external-call "search_for_method_in_list" + :address (pref classptr :objc_class.methods) + :address selector + :address))) + (when (%null-ptr-p method) + (setq new-mlist (make-record :objc_method_list :method_count 1)) + (%setf-macptr method (pref new-mlist :objc_method_list.method_list))) + (setf (pref method :objc_method.method_name) selector + (pref method :objc_method.method_types) ctypestring + (pref method :objc_method.method_imp) imp) + (if new-mlist + (external-call "GSObjCAddMethods" + :address classptr + :address new-mlist + :void) + (external-call "__objc_update_dispatch_table_for_class" + :address classptr + :void))))))) (defvar *lisp-objc-methods* (make-hash-table :test #'eq)) @@ -1758,6 +1778,10 @@ (rlet ((,super :objc_super #+apple-objc :receiver #+gnu-objc :self ,self - :class + #+apple-objc-2.0 :super_class #-apple-objc-2.0 :class ,@(if class-p + #+apple-objc-2.0 + `((external-call "_class_getSuperclass" + :address (pref (@class ,class-name) :objc_class.isa) :address)) + #-apple-objc-2.0 `((pref (pref (@class ,class-name) @@ -1765,4 +1789,8 @@ #+gnu-objc :objc_class.super_class ) :objc_class.super_class)) + #+apple-objc-2.0 + `((external-call "_class_getSuperclass" + :address (@class ,class-name) :address)) + #-apple-objc-2.0 `((pref (@class ,class-name) :objc_class.super_class))))) (macrolet ((send-super (msg &rest args &environment env) @@ -1793,19 +1821,5 @@ (defun class-get-instance-method (class sel) - #+apple-objc (let* ((p (#_class_getInstanceMethod class sel))) - (if (%null-ptr-p p) - (unless (logtest #$CLS_INITIALIZED (pref (pref class :objc_class.isa) :objc_class.info)) - ;; Do this for effect; ignore the : it returns. - ;; (It should cause the CLS_NEED_BIND flag to turn itself - ;; off after the class has been initialized; we need - ;; the class and all superclasses to have been initialized, - ;; so that we can find category methods via - ;; #_class_getInstanceMethod. - (external-call "_class_lookupMethod" - :id class - : sel - :address) - (%setf-macptr p (#_class_getInstanceMethod class sel)))) - p) + #+apple-objc (#_class_getInstanceMethod class sel) #+gnu-objc (#_class_get_instance_method class sel)) @@ -1842,20 +1856,4 @@ :key #'function-name) ) - -;;; Return a typestring and offset as multiple values. - -(defun objc-get-method-argument-info (m i) - #+apple-objc - (%stack-block ((type 4) (offset 4)) - (#_method_getArgumentInfo m i type offset) - (values (%get-cstring (%get-ptr type)) (%get-signed-long offset))) - #+gnu-objc - (progn - (with-macptrs ((typespec (#_objc_skip_argspec (pref m :objc_method.method_types)))) - (dotimes (j i (values (%get-cstring typespec) - (#_strtol (#_objc_skip_typespec typespec) - (%null-ptr) - 10.))) - (%setf-macptr typespec (#_objc_skip_argspec typespec)))))) @@ -1893,4 +1891,39 @@ (%get-cstring cstring)))) +#+apple-objc-2.0 +;;; This isn't defined in headers; it's sort of considered a built-in +;;; type by the ObjC frontend. (See also the ObjC runtime source.) +(eval-when (:compile_toplevel :execute) + (def-foreign-type nil + (:struct :_objc_exception_data + (:buf :jmp_buf) + (:pointers (:array :address 4))))) + +;;; Apple's mechanism for maintaining per-thread exception handler +;;; state isn't thread safe, which suggests that we should probably +;;; install our own callbacks via #_objc_exception_set_functions. +;;; It's 2007. + +#+apple-objc-2.0 +(defmacro with-ns-exceptions-as-errors (&body body) + (let* ((data (gensym)) + (cframe (gensym))) + `(rletZ ((,data :_objc_exception_data)) + (unwind-protect + (progn + (#_objc_exception_try_enter ,data) + (catch ,data + (with-c-frame ,cframe + (%associate-jmp-buf-with-catch-frame + ,data + (%fixnum-ref (%current-tcr) target::tcr.catch-top) + ,cframe) + (progn + ,@body)))) + (check-ns-exception ,data))))) + + + +#-apple-objc-2.0 (defmacro with-ns-exceptions-as-errors (&body body) #+apple-objc @@ -1914,5 +1947,12 @@ ) -#+apple-objc +#+apple-objc-2.0 +(defun check-ns-exception (data) + (with-macptrs ((exception (#_objc_exception_extract data))) + (if (%null-ptr-p exception) + (#_objc_exception_try_exit data) + (error (ns-exception->lisp-condition (%inc-ptr exception 0)))))) + +#+(and apple-objc (not apple-objc-2.0)) (defun check-ns-exception (nshandler) (with-macptrs ((exception (external-call "__NSExceptionObjectFromHandler2"