Changeset 6059

Timestamp:

Mar 17, 2007, 7:16:54 PM (18 years ago)

Author:

Gary Byers

Message:

Extend the idea previously used for precompiled INIT messages to all
messages; lazily compile a function which knows how to ff-call each
type signature encountered.

Provide varargs support for Darwin x86-64 (so far); ToDo: others.

File:

• branches/objc-gf/ccl/examples/objc-runtime.lisp (modified) (10 diffs)

branches/objc-gf/ccl/examples/objc-runtime.lisp

@@ -69 +69 @@
 ;;; methods
 (defloadvar *objc-protocols* (make-hash-table :test #'equal))
+
+(defstruct objc-protocol
+  name
+  address)
 
 (defun lookup-objc-protocol (name)
@@ -741 +745 @@
                     (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 +761 @@
                 (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 +980 @@
            *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 +1233 @@
        ,@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 :<BOOL>)
+      `(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 :<MARG> (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 :<BOOL>)
+               (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
+                                          :<MARG> :bytes)
+                                        (* 8 ,stack-total))))
+             
+             (setf (pref ,marg-ptr :<MARG>.rax) ,stack-total)
+             (with-macptrs ((,regparams (pref ,marg-ptr :<MARG>.reg<P>arams)) 
+                            (,stackparams (pref ,marg-ptr :<MARG>.stack<P>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 :<SEL>)
+            (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
+                         (:<BOOL> (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 +1841 @@
             (objc-metaclass-id-foreign-name meta-id) class-name
             (find-class meta-name) meta)
+      (%defglobal name class)
+      (%defglobal meta-name meta)
     class)))
 
@@ -1602 +1889 @@
 
 
-(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
-            (:<BOOL> (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
-                  :<SEL> (%get-selector selector)
-                  ,@(call))
-                 #+gnu-objc
-                 (let* ((s (%get-selector selector))
-                        (imp (external-call "objc_msg_lookup"
-                                            :id self
-                                            :<SEL> s
-                                            :<IMP>)))
-                   (ff-call imp :id self :<SEL> 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 +1911 @@
                                       #'(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 +1923 @@
     (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 +2459 @@
 
 
-(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))))
+
+