Index: /trunk/ccl/examples/objc-runtime.lisp =================================================================== --- /trunk/ccl/examples/objc-runtime.lisp (revision 5888) +++ /trunk/ccl/examples/objc-runtime.lisp (revision 5889) @@ -108,31 +108,22 @@ -(let* ((objc-class-map (make-splay-tree #'%ptr-eql - #'(lambda (x y) - (< (the (unsigned-byte 32) - (%ptr-to-int x)) - (the (unsigned-byte 32) - (%ptr-to-int Y)))))) - (objc-metaclass-map (make-splay-tree #'%ptr-eql - #'(lambda (x y) - (< (the (unsigned-byte 32) - (%ptr-to-int x)) - (the (unsigned-byte 32) - (%ptr-to-int Y)))))) +(defun %ptr< (x y) + (< (the (unsigned-byte #+64-bit-target 64 #+32-bit-target 32) + (%ptr-to-int x)) + (the (unsigned-byte #+64-bit-target 64 #+32-bit-target 32) + (%ptr-to-int Y)))) + +(let* ((objc-class-map (make-splay-tree #'%ptr-eql #'%ptr<)) + (objc-metaclass-map (make-splay-tree #'%ptr-eql #'%ptr<)) ;;; These are NOT lisp classes; we mostly want to keep track ;;; of them so that we can pretend that instances of them ;;; are instances of some known (declared) superclass. - (private-objc-classes (make-splay-tree #'%ptr-eql - #'(lambda (x y) - (< (the (unsigned-byte 32) - (%ptr-to-int x)) - (the (unsigned-byte 32) - (%ptr-to-int Y)))))) + (private-objc-classes (make-splay-tree #'%ptr-eql #'%ptr<)) (objc-class-lock (make-lock)) (next-objc-class-id 0) (next-objc-metaclass-id 0) (class-table-size 1024) - (c (make-array 1024)) - (m (make-array 1024)) + (c (make-array class-table-size)) + (m (make-array class-table-size)) (cw (make-array 1024 :initial-element nil)) (mw (make-array 1024 :initial-element nil)) @@ -289,5 +280,5 @@ ;;; Open shared libs. -#+darwinppc-target +#+darwin-target (progn (defloadvar *cocoa-event-process* *initial-process*) @@ -438,9 +429,7 @@ (defloadvar *NSConstantString-class* - #+apple-objc - (foreign-symbol-address "__NSConstantStringClassReference") - #+gnu-objc (with-cstrs ((name "NSConstantString")) - (#_objc_lookup_class name))) + #+apple-objc (#_objc_lookUpClass name) + #+gnu-objc (#_objc_lookup_class name))) @@ -473,4 +462,24 @@ (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")) + +;;; These constants also come from Libc sources. Hey, who needs +;;; header files ? +#+x8664-target +(progn +(defconstant JB-RBX 0) +(defconstant JB-RBP 8) +(defconstant JB-RSP 16) +(defconstant JB-R12 24) +(defconstant JB-R13 32) +(defconstant JB-R14 40) +(defconstant JB-R15 48) +(defconstant JB-RIP 56) +(defconstant JB-RFLAGS 64) +(defconstant JB-MXCSR 72) +(defconstant JB-FPCONTROL 76) +(defconstant JB-MASK 80) +) + + @@ -484,4 +493,5 @@ ;;; place. +#+ppc-target (macrolet ((ppc-lap-word (instruction-form) (uvref (uvref (compile nil @@ -503,4 +513,14 @@ p))) +#+x8664-target +(defloadvar *setjmp-catch-rip-code* + (let* ((code-bytes '(#x4c #x89 #xe6 ; movq %r12, %rsi + #xff #xd3)) ; call *%rbx + (nbytes (length code-bytes)) + (p (malloc nbytes))) + (dotimes (i nbytes p) + (setf (%get-unsigned-byte p i) (pop code-bytes))))) + + ;;; Catch frames are allocated on a stack, so it's OK to pass their ;;; addresses around to foreign code. @@ -515,4 +535,5 @@ ;;; an empty C stack frame from which the callback will be called. +#+ppc-target (defun %associate-jmp-buf-with-catch-frame (jmp-buf catch-frame c-frame) (%set-object jmp-buf JMP-sp c-frame) @@ -523,4 +544,14 @@ (%get-ptr jmp-buf JMP-r14) throw-to-catch-frame) t) + +#+x8664-target +(defun %associate-jmp-buf-with-catch-frame (jmp-buf catch-frame c-frame) + (setf (%get-ptr jmp-buf JB-rbx) throw-to-catch-frame + (%get-ptr jmp-buf JB-rip) *setjmp-catch-rip-code*) + (%set-object jmp-buf JB-RSP c-frame) + (%set-object jmp-buf JB-RBP c-frame) + (%set-object jmp-buf JB-r12 catch-frame) + t) + ) @@ -962,10 +993,18 @@ ;;; - Lisp numbers => SINGLE-FLOAT when possible -(defmacro coerce-to-bool (x) +(defun coerce-to-bool (x) (let ((x-temp (gensym))) `(let ((,x-temp ,x)) - (if (or (eq ,x-temp 0) (null ,x-temp)) #.#$NO #.#$YES)))) - -(defmacro coerce-to-address (x) + (if (or (eq ,x-temp 0) (null ,x-temp)) + #.#$NO + #.#$YES)))) + +(declaim (inline %coerce-to-bool)) +(defun %coerce-to-bool (x) + (if (and x (not (eql x 0))) + #$YES + #$NO)) + +(defun coerce-to-address (x) (let ((x-temp (gensym))) `(let ((,x-temp ,x)) @@ -974,5 +1013,17 @@ (t ,x-temp))))) -(defmacro coerce-to-foreign-type (x ftype) +;;; This is generally a bad idea; it forces us to +;;; box intermediate pointer arguments in order +;;; to typecase on them, and it's not clear to +;;; me that it offers much in the way of additional +;;; expressiveness. +(declaim (inline %coerce-to-address)) +(defun %coerce-to-address (x) + (etypecase x + (macptr x) + (string (%make-nsstring x)) ; does this ever get released ? + (null (%null-ptr)))) + +(defun coerce-to-foreign-type (x ftype) (cond ((and (constantp x) (constantp ftype)) (case ftype @@ -982,14 +1033,17 @@ ((constantp ftype) (case ftype - (:id `(coerce-to-address ,x)) - (: `(coerce-to-bool ,x)) + (:id `(%coerce-to-address ,x)) + (: `(%coerce-to-bool ,x)) (t x))) (t `(case ,(if (atom ftype) ftype) - (:id (coerce-to-address ,x)) - (: (coerce-to-bool ,x)) + (:id (%coerce-to-address ,x)) + (: (%coerce-to-bool ,x)) (t ,x))))) (defun objc-arg-coerce (typespec arg) - (coerce-to-foreign-type arg typespec)) + (case typespec + (: `(%coerce-to-bool ,arg)) + (:id `(%coerce-to-address ,arg)) + (t arg))) @@ -1035,6 +1089,6 @@ #+apple-objc (funcall (ftd-ff-call-expand-function *target-ftd*) - `(external-call "_objc_msgSend") - `(:id ,receiver : (@selector ,selector-name) ,@argspecs) + `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSend")))) + `(:address ,receiver : (@selector ,selector-name) ,@argspecs) :arg-coerce 'objc-arg-coerce :result-coerce 'objc-result-coerce) @@ -1051,5 +1105,5 @@ (funcall (ftd-ff-call-expand-function *target-ftd*) `(%ff-call ,imp) - `(:id ,receiver : (@selector ,selector-name) ,@argspecs) + `(:address ,receiver : (@selector ,selector-name) ,@argspecs) :arg-coerce 'objc-arg-coerce :result-coerce 'objc-result-coerce)))) @@ -1084,8 +1138,8 @@ (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec) "_objc_msgSend_stret" - "_objc-msgSend"))) + "_objc_msgSend"))) (funcall (ftd-ff-call-expand-function *target-ftd*) - `(%ff-call (external ,entry-name)) - `(,structptr :id ,receiver : (@selector ,selector-name) ,@argspecs) + `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name)))) + `(,structptr :address ,receiver : (@selector ,selector-name) ,@argspecs) :arg-coerce 'objc-arg-coerce :result-coerce 'objc-result-coerce)) @@ -1102,5 +1156,5 @@ , (funcall (ftd-ff-call-expand-function *target-ftd*) `(%ff-call ,imp) - `(,structptr :id , : ,s ,@argspecs) + `(,structptr :address ,receiver : ,s ,@argspecs) :arg-coerce 'objc-arg-coerce :result-coerce 'objc-result-coerce)))) @@ -1115,5 +1169,5 @@ #+apple-objc (funcall (ftd-ff-call-expand-function *target-ftd*) - `(%ff-call (external "_objc_msgSendSuper")) + `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSendSuper")))) `(:address ,super : (@selector ,selector-name) ,@argspecs) :arg-coerce 'objc-arg-coerce @@ -1142,7 +1196,7 @@ (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec) "_objc_msgSendSuper_stret" - "_objc-msgSendSuper"))) + "_objc_msgSendSuper"))) (funcall (ftd-ff-call-expand-function *target-ftd*) - `(%ff-call (external ,entry-name)) + `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name)))) `(,structptr :address ,super : (@selector ,selector-name) ,@argspecs) :arg-coerce 'objc-arg-coerce @@ -1176,8 +1230,11 @@ ) + + ;;; The first 13 fp arguments get passed in F1-F13 (and also "consume" ;;; a GPR or two.) It's certainly possible for an FP arg and a non- ;;; FP arg to share the same "offset", and parameter offsets aren't ;;; strictly increasing. +#+ppc-target (defvar *objc-fpr-offsets* #+32-bit-target @@ -1257,5 +1314,6 @@ (format nil "^~a" (encode-objc-type element-type)))))) (t (break "type = ~s" type))))))) - + +#+ppc-target (defun encode-objc-method-arglist (arglist result-spec) (let* ((gprs-used 0) @@ -1284,5 +1342,5 @@ (incf gprs-used 2)) (foreign-single-float-type - (setq size 4 offset (current-fpr-arg-offset)) + (setq size target::node-size offset (current-fpr-arg-offset)) (incf fprs-used) (incf gprs-used 1)) @@ -1294,10 +1352,10 @@ (setq size (ceiling bits 8) offset (current-gpr-arg-offset)) - (incf gprs-used (ceiling bits 32)))) + (incf gprs-used (ceiling bits target::nbits-in-word)))) ((or foreign-record-type foreign-array-type) (let* ((bits (ensure-foreign-type-bits arg))) (setq size (ceiling bits 8) offset (current-gpr-arg-offset)) - (incf gprs-used (ceiling bits 32)))) + (incf gprs-used (ceiling bits target::nbits-in-word)))) (t (break "argspec = ~s, arg = ~s" argspec arg))) (push (list (encode-objc-type arg) offset size) result)))))))) @@ -1307,4 +1365,30 @@ arg-info)) objc-forwarding-stack-offset))) + (format nil "~a~d~:{~a~d~}" + (encode-objc-type + (parse-foreign-type result-spec)) + max-parm-end + arg-info)))) + +#+x8664-target +(defun encode-objc-method-arglist (arglist result-spec) + (let* ((offset 0) + (arg-info + (let* ((result nil)) + (dolist (argspec arglist (nreverse result)) + (let* ((arg (parse-foreign-type argspec)) + (delta 8)) + (typecase arg + (foreign-double-float-type) + (foreign-single-float-type) + ((or foreign-pointer-type foreign-array-type)) + (foreign-integer-type) + (foreign-record-type + (let* ((bits (ensure-foreign-type-bits arg))) + (setq delta (ceiling bits 8)))) + (t (break "argspec = ~s, arg = ~s" argspec arg))) + (push (list (encode-objc-type arg) offset) result) + (setq offset (* 8 (ceiling (+ offset delta) 8)))))))) + (let* ((max-parm-end offset)) (format nil "~a~d~:{~a~d~}" (encode-objc-type @@ -1537,6 +1621,6 @@ (call type) (case type - (: (call `(coerce-to-bool ,arg))) - (:id (call `(coerce-to-address ,arg))) + (: (call `(%coerce-to-bool ,arg))) + (:id (call `(%coerce-to-address ,arg))) (otherwise (call arg))))) ;; all "init" messages return :id @@ -1608,19 +1692,5 @@ init-info))) -(defun send-init-message-with-info (instance init-info args) - (let* ((selector (objc-init-message-info-selector init-info)) - (alist (objc-init-message-info-method-signature-alist init-info)) - (pair (do* ((alist alist (cdr alist))) - ((null (cdr alist)) - (car alist) - (let* ((pair (car alist))) - (dolist (class (cdr pair)) - (when (typep instance class) - (return pair)))))))) - (with-ns-exceptions-as-errors - (apply (objc-init-method-signature-info-function (car pair)) - instance - selector - args)))) + @@ -1640,19 +1710,7 @@ "Maps from lists of init keywords to OBJC-INIT-MESSAGE structures") -(defun send-objc-init-message-with-info (instance init-info args) - (let* ((selector (objc-init-message-info-selector init-info)) - (alist (objc-init-message-info-method-signature-alist init-info)) - (pair (do* ((alist alist (cdr alist))) - ((null (cdr alist)) - (car alist) - (let* ((pair (car alist))) - (dolist (class (cdr pair)) - (when (typep instance class) - (return pair)))))))) - (with-ns-exceptions-as-errors - (apply (objc-init-method-signature-info-function (car pair)) - instance - selector - args)))) + + + @@ -1668,6 +1726,5 @@ (send-objc-init-message-with-info instance info args))) -(defun allocate-objc-object (class) - (send class 'alloc)) + @@ -2069,5 +2126,5 @@ #+gnu-objc (#_method_get_number_of_arguments m)) -#+apple-objc +#+(and apple-objc (not apple-objc-2.0)) (progn (defloadvar *original-deallocate-hook* @@ -2118,5 +2175,5 @@ `(let ((,pool-temp (create-autorelease-pool))) (unwind-protect - ,@body + (progn ,@body) (release-autorelease-pool ,pool-temp))))) @@ -2137,8 +2194,4 @@ (: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 @@ -2150,5 +2203,5 @@ (progn (#_objc_exception_try_enter ,data) - (catch ,data + (catch ,data (with-c-frame ,cframe (%associate-jmp-buf-with-catch-frame @@ -2201,2 +2254,17 @@ +(defun send-objc-init-message-with-info (instance init-info args) + (let* ((selector (objc-init-message-info-selector init-info)) + (alist (objc-init-message-info-method-signature-alist init-info)) + (pair (do* ((alist alist (cdr alist))) + ((null (cdr alist)) + (car alist) + (let* ((pair (car alist))) + (dolist (class (cdr pair)) + (when (typep instance class) + (return pair)))))))) + (with-ns-exceptions-as-errors + (apply (objc-init-method-signature-info-function (car pair)) + instance + selector + args))))