Index: /branches/objc-gf/ccl/examples/objc-runtime.lisp =================================================================== --- /branches/objc-gf/ccl/examples/objc-runtime.lisp (revision 6058) +++ /branches/objc-gf/ccl/examples/objc-runtime.lisp (revision 6059) @@ -69,4 +69,8 @@ ;;; methods (defloadvar *objc-protocols* (make-hash-table :test #'equal)) + +(defstruct objc-protocol + name + address) (defun lookup-objc-protocol (name) @@ -741,5 +745,6 @@ (setf (objc-metaclass-id-foreign-name meta-id) meta-foreign-name) - (setf (find-class meta-name) meta))) + (setf (find-class meta-name) meta) + (%defglobal meta-name meta))) (setf (slot-value class 'direct-slots) (compute-objc-direct-slots-from-info decl class)) @@ -756,5 +761,7 @@ (setf (objc-class-id-foreign-name id) name) - (setf (find-class class-name) class))))))))) + (setf (find-class class-name) class) + (%defglobal class-name class) + class)))))))) @@ -973,8 +980,13 @@ *objc-selectors*)) +;;; Find or create a SELECTOR; don't bother resolving it. +(defun ensure-objc-selector (name) + (setq name (string name)) + (or (gethash name *objc-selectors*) + (setf (gethash name *objc-selectors*) + (make-objc-selector :name name)))) + (defun load-objc-selector (name) - (let* ((selector (or (gethash name *objc-selectors*) - (setf (gethash name *objc-selectors*) - (make-objc-selector :name name))))) + (let* ((selector (ensure-objc-selector name))) (%get-SELECTOR selector nil) selector)) @@ -1221,4 +1233,277 @@ ,@argspecs)))) +(defun message-send-form-for-call (args result-spec super-p) + (let* ((form + #+apple-objc + (let* ((entry (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) result-spec) + (if super-p + "_objc_msgSendSuper_stret" + "_objc_msgSend_stret") + (if super-p + "_objc_msgSendSuper" + "_objc_msgSend")))) + `(external-call ,entry ,@args)) + #+gnu-objc + (break))) + (if (eq result-spec :) + `(coerce-from-bool ,form) + form))) + +#+(and apple-objc x8664-target) +(defun %process-varargs-list (gpr-pointer fpr-pointer stack-pointer ngprs nfprs nstackargs arglist) + (dolist (arg-temp arglist) + (typecase arg-temp + ((signed-byte 64) + (if (< ngprs 6) + (progn + (setf (paref gpr-pointer (:* (:signed 64)) ngprs) arg-temp) + (incf ngprs)) + (progn + (setf (paref stack-pointer (:* (:signed 64)) nstackargs) arg-temp) + (incf nstackargs)))) + ((unsigned-byte 64) + (if (< ngprs 6) + (progn + (setf (paref gpr-pointer (:* (:unsigned 64)) ngprs) arg-temp) + (incf ngprs)) + (progn + (setf (paref stack-pointer (:* (:unsigned 64)) nstackargs) arg-temp) + (incf nstackargs)))) + (macptr + (if (< ngprs 6) + (progn + (setf (paref gpr-pointer (:* :address) ngprs) arg-temp) + (incf ngprs)) + (progn + (setf (paref stack-pointer (:* :address) nstackargs) arg-temp) + (incf nstackargs)))) + (foreign-struct-encapsulation + (if (< ngprs 6) + (progn + (setf (paref gpr-pointer (:* :address) ngprs) + (foreign-struct-encapsulation-data arg-temp)) + (incf ngprs)) + (progn + (setf (paref stack-pointer (:* :address) nstackargs) + (foreign-struct-encapsulation-data arg-temp)) + (incf nstackargs)))) + (single-float + (if (< nfprs 8) + (progn + (setf (%get-single-float fpr-pointer (* nfprs 16)) + arg-temp) + (incf nfprs)) + (progn + (setf (paref stack-pointer (:* :float) (* 2 nstackargs)) arg-temp) + (incf nstackargs)))) + (double-float + (if (< nfprs 8) + (progn + (setf (%get-double-float fpr-pointer (* nfprs 16)) + arg-temp) + (incf nfprs)) + (progn + (setf (paref stack-pointer (:* :double) nstackargs) + arg-temp) + (incf nstackargs))))))) + +#+apple-objc +(eval-when (:compile-toplevel :execute) + #+x8664-target + (%def-foreign-type : (foreign-pointer-type-to (parse-foreign-type :x86_64_marg_list)))) + + +(defun %compile-varargs-send-function-for-signature (sig) + (declare (ignorable sig super-p)) + #+(and apple-objc x8664-target) + (let* ((return-type-spec (car sig)) + (arg-type-specs (butlast (cdr sig))) + (args (objc-gen-message-arglist (length arg-type-specs))) + (receiver (gensym)) + (selector (gensym)) + (rest-arg (gensym)) + (arg-temp (gensym)) + (marg-ptr (gensym)) + (regparams (gensym)) + (stackparams (gensym)) + (selptr (gensym)) + (gpr-total (gensym)) + (fpr-total (gensym)) + (stack-total (gensym)) + (n-static-gprs 2) ;receiver, selptr + (n-static-fprs 0) + (n-static-stack-args 0)) + (collect ((static-arg-forms)) + (static-arg-forms `(setf (paref ,regparams (:* address) 0) ,receiver)) + (static-arg-forms `(setf (paref ,regparams (:* address) 1) ,selptr)) + (do* ((args args (cdr args)) + (arg-type-specs arg-type-specs (cdr arg-type-specs))) + ((null args)) + (let* ((arg (car args)) + (spec (car arg-type-specs)) + (static-arg-type (parse-foreign-type spec)) + (gpr-base (if (< n-static-gprs 6) regparams stackparams)) + (fpr-base (if (< n-static-fprs 8) marg-ptr stackparams)) + (gpr-offset (if (< n-static-gprs 6) n-static-gprs n-static-stack-args)) + (fpr-offset (if (< n-static-fprs 8) + (* 16 n-static-fprs) + (* 8 n-static-stack-args)))) + (etypecase static-arg-type + (foreign-integer-type + (if (eq spec :) + (setq arg `(%coerce-to-bool ,arg))) + (static-arg-forms + `(setf (paref ,gpr-base (:* ( + ,(if (foreign-integer-type-signed static-arg-type) + :signed + :unsigned) + ,(foreign-integer-type-bits static-arg-type))) ,gpr-offset) + ,arg)) + (if (< n-static-gprs 6) + (incf n-static-gprs) + (incf n-static-stack-args))) + (foreign-single-float-type + (if (eq fpr-base stackparams) + (setq fpr-offset (* 2 fpr-offset))) + (static-arg-forms + `(setf (%get-single-float ,fpr-base ,fpr-offset) ,arg)) + (if (< n-static-fprs 8) + (incf n-static-fprs) + (incf n-static-stack-args))) + (foreign-double-float-type + (static-arg-forms + `(setf (%get-double-float ,fpr-base ,fpr-offset) ,arg)) + (if (< n-static-fprs 8) + (incf n-static-fprs) + (incf n-static-stack-args))) + (foreign-pointer-type + (let* ((to (foreign-pointer-type-to static-arg-type)) + (coerce (get-foreign-struct-association to))) + (if coerce + (setq arg `(foreign-struct-encapsulation-data ,arg)))) + (static-arg-forms + `(setf (paref ,gpr-base (:* address) ,gpr-offset) ,arg)) + (if (< n-static-gprs 6) + (incf n-static-gprs) + (incf n-static-stack-args)))))) + (compile + nil + `(lambda (,receiver ,selector ,@args &rest ,rest-arg) + (declare (dynamic-extent ,rest-arg)) + (let* ((,selptr (%get-selector ,selector)) + (,gpr-total ,n-static-gprs) + (,fpr-total ,n-static-fprs) + (,stack-total ,n-static-stack-args)) + (dolist (,arg-temp ,rest-arg) + (if (or (typep ,arg-temp 'double-float) + (typep ,arg-temp 'single-float)) + (if (< ,fpr-total 8) + (incf ,fpr-total) + (incf ,stack-total)) + (if (< ,gpr-total 6) + (incf ,gpr-total) + (incf ,stack-total)))) + (%stack-block ((,marg-ptr (+ ,(%foreign-type-or-record-size + : :bytes) + (* 8 ,stack-total)))) + + (setf (pref ,marg-ptr :.rax) ,stack-total) + (with-macptrs ((,regparams (pref ,marg-ptr :.reg

arams)) + (,stackparams (pref ,marg-ptr :.stack

arams))) + (progn ,@(static-arg-forms)) + (%process-varargs-list ,regparams ,marg-ptr ,stackparams ,n-static-gprs ,n-static-fprs ,n-static-stack-args ,rest-arg) + (external-call "_objc_msgSendv" + :address ,receiver + :address ,selptr + :size_t (+ 48 (* 8 ,stack-total)) + :address ,marg-ptr + ,return-type-spec))))))))) + + +(defun %compile-send-function-for-signature (sig &optional super-p) + (let* ((return-type-spec (car sig)) + (arg-type-specs (cdr sig))) + (if (eq (car (last arg-type-specs)) :void) + (%compile-varargs-send-function-for-signature sig) + (let* ((args (objc-gen-message-arglist (length arg-type-specs))) + (struct-return-var nil) + (struct-return-coerce nil) + (receiver (gensym)) + (selector (gensym))) + (collect ((call) + (stack-blocks) ; for anonymous structures + (imports) + (exports)) + (let* ((result-type (parse-foreign-type return-type-spec))) + (if (typep result-type 'foreign-record-type) + (let* ((coerce-info (get-foreign-struct-association result-type))) + (unless coerce-info + (error "Can't return structure type ~s" return-type-spec)) + (setq struct-return-var (gensym)) + (stack-blocks `(,struct-return-var ,(ceiling (require-foreign-type-bits result-type) 8))) + (call struct-return-var) + (setq struct-return-coerce `(funcall ,(foreign-struct-association-return-function coerce-info) ,struct-return-var)))) + (call :id) + (call receiver) + (call :) + (call `(%get-selector ,selector)) + (do ((args args (cdr args)) + (spec (pop arg-type-specs) (pop arg-type-specs))) + ((null args) (call return-type-spec)) + (let* ((arg (car args)) + (ftype (unless (eq spec :id) (parse-foreign-type spec)))) + (cond ((typep ftype 'foreign-record-type) + (let* ((coerce-info (get-foreign-struct-association ftype))) + (unless coerce-info + (error "Can't pass structure-type ~s by value." spec)) + (let* ((temp (gensym))) + (stack-blocks `(,temp ,(ceiling (require-foreign-type-bits ftype) 8))) + (exports `(,(foreign-struct-association-export-function coerce-info) ,arg ,temp)) + (call spec) + (call temp)))) + ;; Pointer to structure type known to be passed by + ;; value/returned ? + ((typep ftype 'foreign-pointer-type) + (let* ((to (foreign-pointer-type-to ftype)) + (coerce-info (if (typep to 'foreign-record-type) + (get-foreign-struct-association to)))) + (if (null coerce-info) + (progn + (call spec) + (call arg)) + (let* ((temp (gensym))) + (stack-blocks `(,temp ,(ceiling (require-foreign-type-bits to) 8))) + (exports `(,(foreign-struct-association-export-function coerce-info) ,arg ,temp)) + (imports `(,(foreign-struct-association-import-function coerce-info) ,arg ,temp)) + (call spec) + (call temp))))) + (t + (call spec) + (case spec + (: (call `(%coerce-to-bool ,arg))) + (:id (call `(%coerce-to-address ,arg))) + (t + (call arg))))))) + (let* ((call (call)) + (stack-blocks (stack-blocks)) + (imports (imports)) + (exports (exports)) + (body (message-send-form-for-call call return-type-spec super-p))) + (if imports + (setq body `(prog1 ,body ,@imports))) + (if struct-return-coerce + (setq body `(progn ,body ,struct-return-coerce))) + (if stack-blocks + (setq body `(%stack-block ,stack-blocks + (progn ,@exports) + ,body))) + (compile nil + `(lambda (,receiver ,selector ,@args) + ,body))))))))) + +(defun compile-send-function-for-signature (sig) + (%compile-send-function-for-signature sig nil)) + + @@ -1556,4 +1841,6 @@ (objc-metaclass-id-foreign-name meta-id) class-name (find-class meta-name) meta) + (%defglobal name class) + (%defglobal meta-name meta) class))) @@ -1602,103 +1889,21 @@ -(let* ((objc-init-message-args (make-array 10 :fill-pointer 0 :adjustable t))) - (defun %objc-init-message-arg (n) - (let* ((len (length objc-init-message-args))) +(let* ((objc-gen-message-args (make-array 10 :fill-pointer 0 :adjustable t))) + (defun %objc-gen-message-arg (n) + (let* ((len (length objc-gen-message-args))) (do* ((i len (1+ i))) - ((> i n) (aref objc-init-message-args n)) - (vector-push-extend (intern (format nil "ARG~d" i)) objc-init-message-args))))) - -(defun objc-init-message-arglist (n) + ((> i n) (aref objc-gen-message-args n)) + (vector-push-extend (intern (format nil "ARG~d" i)) objc-gen-message-args))))) + +(defun objc-gen-message-arglist (n) (collect ((args)) - (dotimes (i n (args)) (args (%objc-init-message-arg i))))) - - -(defun %make-objc-init-function-for-signature (signature) - ;; No structure returns or send-supers involved. - (let* ((types (cdr signature)) - (args (objc-init-message-arglist (length types)))) - (collect ((call)) - (dolist (arg args) - (let* ((type (pop types))) - (call type) - (case type - (: (call `(%coerce-to-bool ,arg))) - (:id (call `(%coerce-to-address ,arg))) - (otherwise (call arg))))) - ;; all "init" messages return :id - (call :id) - (compile nil - `(lambda (self selector ,@args) - #+apple-objc - (external-call "_objc_msgSend" - :id self - : (%get-selector selector) - ,@(call)) - #+gnu-objc - (let* ((s (%get-selector selector)) - (imp (external-call "objc_msg_lookup" - :id self - : s - :))) - (ff-call imp :id self : s ,@(call)))))))) - -(defstruct objc-init-method-signature-info - signature - function) - -(defvar *objc-init-method-signatures* (make-hash-table :test #'equal) - "Maps signature lists to OBJC-INIT-METHOD-SIGNATURE-INFO structures.") - -(defun get-objc-init-method-signature-info (list) - (or (gethash list *objc-init-method-signatures*) - (setf (gethash list *objc-init-method-signatures*) - (make-objc-init-method-signature-info - :signature list - :function (%make-objc-init-function-for-signature list))))) - -(defstruct objc-init-message-info - selector - method-signature-alist - ) - -(defvar *objc-init-messages-for-message-names* (make-hash-table :test #'equal) - "Maps from init message names to OBJC-INIT-MESSAGE-INFO structures.") - -(defun register-objc-init-message (message-info) - (when (dolist (m (objc-message-info-methods message-info)) - (unless (getf (objc-method-info-flags m) :protocol) - (let* ((sig (objc-method-info-signature m))) - (unless (eq (car (last sig)) :void) - (when (eq :id (car (objc-method-info-signature m))) - (return t)))))) - (let* ((name (objc-message-info-message-name message-info)) - (init-info - (or (gethash name *objc-init-messages-for-message-names*) - (setf (gethash name *objc-init-messages-for-message-names*) - (make-objc-init-message-info - :selector (load-objc-selector name) - :method-signature-alist nil)))) - (alist (objc-init-message-info-method-signature-alist init-info))) - (dolist (m (objc-message-info-methods message-info)) - (let* ((sig (objc-method-info-signature m))) - (when (and (eq :id (car sig)) - (not (getf (objc-method-info-flags m) :protocol))) - ;; Looks like a real init method. - (let* ((class (canonicalize-registered-class (lookup-objc-class (objc-method-info-class-name m)))) - (siginfo (get-objc-init-method-signature-info sig)) - (pair (assoc siginfo alist :test #'eq))) - (if (null pair) - (push (cons siginfo (list class)) alist) - (pushnew class (cdr pair) :test #'eq)))))) - (setf (objc-init-message-info-method-signature-alist init-info) alist) - init-info))) - - - - -;;; Register init-message-info for all known init messages. (A + (dotimes (i n (args)) (args (%objc-gen-message-arg i))))) + + + +;;; Call get-objc-message-info for all known init messages. (A ;;; message is an "init message" if it starts with the string "init", -;;; accepts a fixed number of arguments, and has at least one declared -;;; method that returns :ID and is not a protocol method. +;;; and has at least one declared method that returns :ID and is not a +;;; protocol method. (defun register-objc-init-messages () (do-interface-dirs (d) @@ -1706,12 +1911,9 @@ #'(lambda (string) (string= string "init" :end1 (min (length string) 4))))) - (register-objc-init-message (get-objc-message-info init))))) + (get-objc-message-info init)))) (defvar *objc-init-messages-for-init-keywords* (make-hash-table :test #'equal) - "Maps from lists of init keywords to OBJC-INIT-MESSAGE structures") - - - + "Maps from lists of init keywords to dispatch-functions for init messages") @@ -1721,10 +1923,10 @@ (unless info (let* ((name (lisp-to-objc-init init-keywords)) - (name-info (gethash name *objc-init-messages-for-message-names*))) + (name-info (get-objc-message-info name nil))) (unless name-info (error "Unknown ObjC init message: ~s" name)) (setf (gethash init-keywords *objc-init-messages-for-init-keywords*) (setq info name-info)))) - (send-objc-init-message-with-info instance info args))) + (apply (objc-message-info-lisp-name info) instance args))) @@ -2257,17 +2459,4 @@ -(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)))) + +