Changeset 6059


Ignore:
Timestamp:
Mar 18, 2007, 2:16:54 AM (13 years ago)
Author:
gb
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:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/objc-gf/ccl/examples/objc-runtime.lisp

    r5912 r6059  
    6969;;; methods
    7070(defloadvar *objc-protocols* (make-hash-table :test #'equal))
     71
     72(defstruct objc-protocol
     73  name
     74  address)
    7175
    7276(defun lookup-objc-protocol (name)
     
    741745                    (setf (objc-metaclass-id-foreign-name meta-id)
    742746                          meta-foreign-name)
    743                     (setf (find-class meta-name) meta)))
     747                    (setf (find-class meta-name) meta)
     748                    (%defglobal meta-name meta)))
    744749                (setf (slot-value class 'direct-slots)
    745750                      (compute-objc-direct-slots-from-info decl class))
     
    756761                (setf (objc-class-id-foreign-name id)
    757762                      name)
    758                 (setf (find-class class-name) class)))))))))
     763                (setf (find-class class-name) class)
     764                (%defglobal class-name class)
     765                class))))))))
    759766                               
    760767
     
    973980           *objc-selectors*))
    974981
     982;;; Find or create a SELECTOR; don't bother resolving it.
     983(defun ensure-objc-selector (name)
     984  (setq name (string name))
     985  (or (gethash name *objc-selectors*)
     986      (setf (gethash name *objc-selectors*)
     987            (make-objc-selector :name name))))
     988
    975989(defun load-objc-selector (name)
    976   (let* ((selector (or (gethash name *objc-selectors*)
    977                        (setf (gethash name *objc-selectors*)
    978                              (make-objc-selector :name name)))))
     990  (let* ((selector (ensure-objc-selector name)))
    979991    (%get-SELECTOR selector nil)
    980992    selector))
     
    12211233       ,@argspecs))))
    12221234
     1235(defun message-send-form-for-call (args result-spec super-p)
     1236  (let* ((form
     1237          #+apple-objc
     1238           (let* ((entry (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) result-spec)
     1239                           (if super-p
     1240                             "_objc_msgSendSuper_stret"
     1241                             "_objc_msgSend_stret")
     1242                           (if super-p
     1243                             "_objc_msgSendSuper"
     1244                             "_objc_msgSend"))))
     1245             `(external-call ,entry ,@args))
     1246           #+gnu-objc
     1247           (break)))
     1248    (if (eq result-spec :<BOOL>)
     1249      `(coerce-from-bool ,form)
     1250      form)))
     1251
     1252#+(and apple-objc x8664-target)
     1253(defun %process-varargs-list (gpr-pointer fpr-pointer stack-pointer ngprs nfprs nstackargs arglist)
     1254  (dolist (arg-temp arglist)
     1255    (typecase arg-temp
     1256      ((signed-byte 64)
     1257       (if (< ngprs 6)
     1258         (progn
     1259           (setf (paref gpr-pointer (:* (:signed 64)) ngprs) arg-temp)
     1260           (incf ngprs))
     1261         (progn
     1262           (setf (paref stack-pointer (:* (:signed 64)) nstackargs) arg-temp)
     1263           (incf nstackargs))))
     1264      ((unsigned-byte 64)
     1265       (if (< ngprs 6)
     1266         (progn
     1267           (setf (paref gpr-pointer (:* (:unsigned 64)) ngprs) arg-temp)
     1268           (incf ngprs))
     1269         (progn
     1270           (setf (paref stack-pointer (:* (:unsigned 64)) nstackargs) arg-temp)
     1271           (incf nstackargs))))
     1272      (macptr
     1273       (if (< ngprs 6)
     1274         (progn
     1275           (setf (paref gpr-pointer (:* :address) ngprs) arg-temp)
     1276           (incf ngprs))
     1277         (progn
     1278           (setf (paref stack-pointer (:* :address) nstackargs) arg-temp)
     1279           (incf nstackargs))))
     1280      (foreign-struct-encapsulation
     1281       (if (< ngprs 6)
     1282         (progn
     1283           (setf (paref gpr-pointer (:* :address) ngprs)
     1284                 (foreign-struct-encapsulation-data arg-temp))
     1285           (incf ngprs))
     1286         (progn
     1287           (setf (paref stack-pointer (:* :address) nstackargs)
     1288                 (foreign-struct-encapsulation-data arg-temp))
     1289           (incf nstackargs))))
     1290      (single-float
     1291       (if (< nfprs 8)
     1292         (progn
     1293           (setf (%get-single-float fpr-pointer (* nfprs 16))
     1294                 arg-temp)
     1295           (incf nfprs))
     1296         (progn
     1297           (setf (paref stack-pointer (:* :float) (* 2 nstackargs)) arg-temp)
     1298           (incf nstackargs))))
     1299      (double-float
     1300       (if (< nfprs 8)
     1301         (progn
     1302           (setf (%get-double-float fpr-pointer (* nfprs 16))
     1303                 arg-temp)
     1304           (incf nfprs))
     1305         (progn
     1306           (setf (paref stack-pointer (:* :double) nstackargs)
     1307                 arg-temp)
     1308           (incf nstackargs)))))))
     1309                         
     1310#+apple-objc
     1311(eval-when (:compile-toplevel :execute)
     1312  #+x8664-target
     1313  (%def-foreign-type :<MARG> (foreign-pointer-type-to (parse-foreign-type :x86_64_marg_list))))
     1314
     1315 
     1316(defun %compile-varargs-send-function-for-signature (sig)
     1317  (declare (ignorable sig super-p))
     1318  #+(and apple-objc x8664-target)
     1319  (let* ((return-type-spec (car sig))
     1320         (arg-type-specs (butlast (cdr sig)))
     1321         (args (objc-gen-message-arglist (length arg-type-specs)))
     1322         (receiver (gensym))
     1323         (selector (gensym))
     1324         (rest-arg (gensym))
     1325         (arg-temp (gensym))
     1326         (marg-ptr (gensym))
     1327         (regparams (gensym))
     1328         (stackparams (gensym))
     1329         (selptr (gensym))
     1330         (gpr-total (gensym))
     1331         (fpr-total (gensym))
     1332         (stack-total (gensym))
     1333         (n-static-gprs 2)              ;receiver, selptr
     1334         (n-static-fprs 0)
     1335         (n-static-stack-args 0))
     1336    (collect ((static-arg-forms))
     1337      (static-arg-forms `(setf (paref ,regparams (:* address) 0) ,receiver))
     1338      (static-arg-forms `(setf (paref ,regparams (:* address) 1) ,selptr))
     1339      (do* ((args args (cdr args))
     1340            (arg-type-specs arg-type-specs (cdr arg-type-specs)))
     1341           ((null args))
     1342        (let* ((arg (car args))
     1343               (spec (car arg-type-specs))
     1344               (static-arg-type (parse-foreign-type spec))
     1345               (gpr-base (if (< n-static-gprs 6) regparams stackparams))
     1346               (fpr-base (if (< n-static-fprs 8) marg-ptr stackparams))
     1347               (gpr-offset (if (< n-static-gprs 6) n-static-gprs n-static-stack-args))
     1348               (fpr-offset (if (< n-static-fprs 8)
     1349                             (* 16 n-static-fprs)
     1350                             (* 8 n-static-stack-args))))
     1351          (etypecase static-arg-type
     1352            (foreign-integer-type
     1353             (if (eq spec :<BOOL>)
     1354               (setq arg `(%coerce-to-bool ,arg)))
     1355             (static-arg-forms
     1356              `(setf (paref ,gpr-base (:* (
     1357                                           ,(if (foreign-integer-type-signed static-arg-type)
     1358                                                :signed
     1359                                                :unsigned)
     1360                                           ,(foreign-integer-type-bits static-arg-type))) ,gpr-offset)
     1361                ,arg))
     1362             (if (< n-static-gprs 6)
     1363               (incf n-static-gprs)
     1364               (incf n-static-stack-args)))
     1365            (foreign-single-float-type
     1366             (if (eq fpr-base stackparams)
     1367               (setq fpr-offset (* 2 fpr-offset)))
     1368             (static-arg-forms
     1369              `(setf (%get-single-float ,fpr-base ,fpr-offset) ,arg))
     1370             (if (< n-static-fprs 8)
     1371               (incf n-static-fprs)
     1372               (incf n-static-stack-args)))
     1373            (foreign-double-float-type
     1374             (static-arg-forms
     1375              `(setf (%get-double-float ,fpr-base ,fpr-offset) ,arg))
     1376             (if (< n-static-fprs 8)
     1377               (incf n-static-fprs)
     1378               (incf n-static-stack-args)))
     1379            (foreign-pointer-type
     1380             (let* ((to (foreign-pointer-type-to static-arg-type))
     1381                    (coerce (get-foreign-struct-association to)))
     1382               (if coerce
     1383                 (setq arg `(foreign-struct-encapsulation-data ,arg))))
     1384             (static-arg-forms
     1385              `(setf (paref ,gpr-base (:* address) ,gpr-offset) ,arg))
     1386             (if (< n-static-gprs 6)
     1387               (incf n-static-gprs)
     1388               (incf n-static-stack-args))))))
     1389      (compile
     1390       nil
     1391       `(lambda (,receiver ,selector ,@args &rest ,rest-arg)
     1392         (declare (dynamic-extent ,rest-arg))
     1393         (let* ((,selptr (%get-selector ,selector))
     1394                (,gpr-total ,n-static-gprs)
     1395                (,fpr-total ,n-static-fprs)
     1396                (,stack-total ,n-static-stack-args))
     1397           (dolist (,arg-temp ,rest-arg)
     1398             (if (or (typep ,arg-temp 'double-float)
     1399                     (typep ,arg-temp 'single-float))
     1400               (if (< ,fpr-total 8)
     1401                 (incf ,fpr-total)
     1402                 (incf ,stack-total))
     1403               (if (< ,gpr-total 6)
     1404                 (incf ,gpr-total)
     1405                 (incf ,stack-total))))
     1406           (%stack-block ((,marg-ptr (+ ,(%foreign-type-or-record-size
     1407                                          :<MARG> :bytes)
     1408                                        (* 8 ,stack-total))))
     1409             
     1410             (setf (pref ,marg-ptr :<MARG>.rax) ,stack-total)
     1411             (with-macptrs ((,regparams (pref ,marg-ptr :<MARG>.reg<P>arams))
     1412                            (,stackparams (pref ,marg-ptr :<MARG>.stack<P>arams)))
     1413               (progn ,@(static-arg-forms))
     1414               (%process-varargs-list ,regparams ,marg-ptr ,stackparams ,n-static-gprs ,n-static-fprs ,n-static-stack-args ,rest-arg)
     1415               (external-call "_objc_msgSendv"
     1416                              :address ,receiver
     1417                              :address ,selptr
     1418                              :size_t (+ 48 (* 8 ,stack-total))
     1419                              :address ,marg-ptr
     1420                              ,return-type-spec)))))))))
     1421
     1422
     1423(defun %compile-send-function-for-signature (sig &optional super-p)
     1424  (let* ((return-type-spec (car sig))
     1425         (arg-type-specs (cdr sig)))
     1426    (if (eq (car (last arg-type-specs)) :void)
     1427      (%compile-varargs-send-function-for-signature sig)
     1428      (let* ((args (objc-gen-message-arglist (length arg-type-specs)))
     1429             (struct-return-var nil)
     1430             (struct-return-coerce nil)
     1431             (receiver (gensym))
     1432             (selector (gensym)))
     1433        (collect ((call)
     1434                  (stack-blocks)        ; for anonymous structures
     1435                  (imports)
     1436                  (exports))
     1437          (let* ((result-type (parse-foreign-type return-type-spec)))
     1438            (if (typep result-type 'foreign-record-type)
     1439              (let* ((coerce-info (get-foreign-struct-association result-type)))
     1440                (unless coerce-info
     1441                  (error "Can't return structure type ~s" return-type-spec))
     1442                (setq struct-return-var (gensym))
     1443                (stack-blocks `(,struct-return-var ,(ceiling (require-foreign-type-bits result-type) 8)))
     1444                (call struct-return-var)
     1445                (setq struct-return-coerce `(funcall ,(foreign-struct-association-return-function coerce-info) ,struct-return-var))))
     1446            (call :id)
     1447            (call receiver)
     1448            (call :<SEL>)
     1449            (call `(%get-selector ,selector))
     1450            (do ((args args (cdr args))
     1451                 (spec (pop arg-type-specs) (pop arg-type-specs)))
     1452                ((null args) (call return-type-spec))
     1453              (let* ((arg (car args))
     1454                     (ftype (unless (eq spec :id) (parse-foreign-type spec))))
     1455                (cond ((typep ftype 'foreign-record-type)
     1456                       (let* ((coerce-info (get-foreign-struct-association ftype)))
     1457                         (unless coerce-info
     1458                           (error "Can't pass structure-type ~s by value." spec))
     1459                         (let* ((temp (gensym)))
     1460                           (stack-blocks `(,temp ,(ceiling (require-foreign-type-bits ftype) 8)))
     1461                           (exports `(,(foreign-struct-association-export-function coerce-info) ,arg ,temp))
     1462                           (call spec)
     1463                           (call temp))))
     1464                      ;; Pointer to structure type known to be passed by
     1465                      ;; value/returned ?
     1466                      ((typep ftype 'foreign-pointer-type)
     1467                       (let* ((to (foreign-pointer-type-to ftype))
     1468                              (coerce-info (if (typep to 'foreign-record-type)
     1469                                             (get-foreign-struct-association to))))
     1470                         (if (null coerce-info)
     1471                           (progn
     1472                             (call spec)
     1473                             (call arg))
     1474                           (let* ((temp (gensym)))
     1475                             (stack-blocks `(,temp ,(ceiling (require-foreign-type-bits to) 8)))
     1476                             (exports `(,(foreign-struct-association-export-function coerce-info) ,arg ,temp))
     1477                             (imports `(,(foreign-struct-association-import-function coerce-info) ,arg ,temp))
     1478                             (call spec)
     1479                             (call temp)))))
     1480                      (t
     1481                       (call spec)
     1482                       (case spec
     1483                         (:<BOOL> (call `(%coerce-to-bool ,arg)))
     1484                         (:id (call `(%coerce-to-address ,arg)))
     1485                         (t
     1486                          (call arg)))))))
     1487            (let* ((call (call))
     1488                   (stack-blocks (stack-blocks))
     1489                   (imports (imports))
     1490                   (exports (exports))
     1491                   (body (message-send-form-for-call call return-type-spec super-p)))
     1492              (if imports
     1493                (setq body `(prog1 ,body ,@imports)))
     1494              (if struct-return-coerce
     1495                (setq body `(progn ,body ,struct-return-coerce)))
     1496              (if stack-blocks
     1497                (setq body `(%stack-block ,stack-blocks
     1498                             (progn ,@exports)
     1499                             ,body)))
     1500              (compile nil
     1501                       `(lambda (,receiver ,selector ,@args)
     1502                         ,body)))))))))
     1503
     1504(defun compile-send-function-for-signature (sig)
     1505  (%compile-send-function-for-signature sig nil))
     1506                           
     1507                   
    12231508
    12241509
     
    15561841            (objc-metaclass-id-foreign-name meta-id) class-name
    15571842            (find-class meta-name) meta)
     1843      (%defglobal name class)
     1844      (%defglobal meta-name meta)
    15581845    class)))
    15591846
     
    16021889
    16031890
    1604 (let* ((objc-init-message-args (make-array 10 :fill-pointer 0 :adjustable t)))
    1605   (defun %objc-init-message-arg (n)
    1606     (let* ((len (length objc-init-message-args)))
     1891(let* ((objc-gen-message-args (make-array 10 :fill-pointer 0 :adjustable t)))
     1892  (defun %objc-gen-message-arg (n)
     1893    (let* ((len (length objc-gen-message-args)))
    16071894      (do* ((i len (1+ i)))
    1608            ((> i n) (aref objc-init-message-args n))
    1609         (vector-push-extend (intern (format nil "ARG~d" i)) objc-init-message-args)))))
    1610 
    1611 (defun objc-init-message-arglist (n)
     1895           ((> i n) (aref objc-gen-message-args n))
     1896        (vector-push-extend (intern (format nil "ARG~d" i)) objc-gen-message-args)))))
     1897
     1898(defun objc-gen-message-arglist (n)
    16121899  (collect ((args))
    1613     (dotimes (i n (args)) (args (%objc-init-message-arg i)))))
    1614 
    1615 
    1616 (defun %make-objc-init-function-for-signature (signature)
    1617   ;; No structure returns or send-supers involved.
    1618   (let* ((types (cdr signature))
    1619          (args (objc-init-message-arglist (length types))))
    1620     (collect ((call))
    1621       (dolist (arg args)
    1622         (let* ((type (pop types)))
    1623           (call type)
    1624           (case type
    1625             (:<BOOL> (call `(%coerce-to-bool ,arg)))
    1626             (:id (call `(%coerce-to-address ,arg)))
    1627             (otherwise (call arg)))))
    1628       ;; all "init" messages return :id
    1629       (call :id)
    1630       (compile nil
    1631                `(lambda (self selector ,@args)
    1632                  #+apple-objc
    1633                  (external-call "_objc_msgSend"
    1634                   :id self
    1635                   :<SEL> (%get-selector selector)
    1636                   ,@(call))
    1637                  #+gnu-objc
    1638                  (let* ((s (%get-selector selector))
    1639                         (imp (external-call "objc_msg_lookup"
    1640                                             :id self
    1641                                             :<SEL> s
    1642                                             :<IMP>)))
    1643                    (ff-call imp :id self :<SEL> s ,@(call))))))))
    1644 
    1645 (defstruct objc-init-method-signature-info
    1646   signature
    1647   function)
    1648 
    1649 (defvar *objc-init-method-signatures* (make-hash-table :test #'equal)
    1650   "Maps signature lists to OBJC-INIT-METHOD-SIGNATURE-INFO structures.")
    1651 
    1652 (defun get-objc-init-method-signature-info (list)
    1653   (or (gethash list *objc-init-method-signatures*)
    1654       (setf (gethash list *objc-init-method-signatures*)
    1655             (make-objc-init-method-signature-info
    1656              :signature list
    1657              :function (%make-objc-init-function-for-signature list)))))
    1658 
    1659 (defstruct objc-init-message-info
    1660   selector
    1661   method-signature-alist
    1662   )
    1663 
    1664 (defvar  *objc-init-messages-for-message-names* (make-hash-table :test #'equal)
    1665   "Maps from init message names to OBJC-INIT-MESSAGE-INFO structures.")
    1666 
    1667 (defun register-objc-init-message (message-info)
    1668   (when (dolist (m (objc-message-info-methods message-info))
    1669           (unless (getf (objc-method-info-flags m) :protocol)
    1670             (let* ((sig (objc-method-info-signature m)))
    1671               (unless (eq (car (last sig)) :void)
    1672                 (when (eq :id (car (objc-method-info-signature m)))
    1673                   (return t))))))
    1674     (let* ((name (objc-message-info-message-name message-info))
    1675            (init-info
    1676             (or (gethash name *objc-init-messages-for-message-names*)
    1677                 (setf (gethash name *objc-init-messages-for-message-names*)
    1678                       (make-objc-init-message-info
    1679                        :selector (load-objc-selector name)
    1680                        :method-signature-alist nil))))
    1681            (alist (objc-init-message-info-method-signature-alist init-info)))
    1682       (dolist (m (objc-message-info-methods message-info))
    1683         (let* ((sig (objc-method-info-signature m)))
    1684           (when (and (eq :id (car sig))
    1685                      (not (getf (objc-method-info-flags m) :protocol)))
    1686             ;; Looks like a real init method.
    1687             (let* ((class (canonicalize-registered-class (lookup-objc-class (objc-method-info-class-name m))))
    1688                    (siginfo (get-objc-init-method-signature-info sig))
    1689                    (pair (assoc siginfo alist :test #'eq)))
    1690               (if (null pair)
    1691                 (push (cons siginfo (list class)) alist)
    1692                 (pushnew class (cdr pair) :test #'eq))))))
    1693       (setf (objc-init-message-info-method-signature-alist init-info) alist)
    1694       init-info)))
    1695 
    1696 
    1697                                                        
    1698 
    1699 ;;; Register init-message-info for all known init messages.  (A
     1900    (dotimes (i n (args)) (args (%objc-gen-message-arg i)))))
     1901
     1902
     1903
     1904;;; Call get-objc-message-info for all known init messages.  (A
    17001905;;; message is an "init message" if it starts with the string "init",
    1701 ;;; accepts a fixed number of arguments, and has at least one declared
    1702 ;;; method that returns :ID and is not a protocol method.
     1906;;; and has at least one declared method that returns :ID and is not a
     1907;;; protocol method.
    17031908(defun register-objc-init-messages ()
    17041909  (do-interface-dirs (d)
     
    17061911                                      #'(lambda (string)
    17071912                                          (string= string "init" :end1 (min (length string) 4)))))
    1708       (register-objc-init-message (get-objc-message-info init)))))
     1913      (get-objc-message-info init))))
    17091914
    17101915   
    17111916(defvar *objc-init-messages-for-init-keywords* (make-hash-table :test #'equal)
    1712   "Maps from lists of init keywords to OBJC-INIT-MESSAGE structures")
    1713 
    1714 
    1715 
     1917  "Maps from lists of init keywords to dispatch-functions for init messages")
    17161918
    17171919
     
    17211923    (unless info
    17221924      (let* ((name (lisp-to-objc-init init-keywords))
    1723              (name-info (gethash name *objc-init-messages-for-message-names*)))
     1925             (name-info (get-objc-message-info name nil)))
    17241926        (unless name-info
    17251927          (error "Unknown ObjC init message: ~s" name))
    17261928        (setf (gethash init-keywords *objc-init-messages-for-init-keywords*)
    17271929              (setq info name-info))))
    1728     (send-objc-init-message-with-info instance info args)))   
     1930    (apply (objc-message-info-lisp-name info) instance args)))
    17291931                   
    17301932
     
    22572459
    22582460
    2259 (defun send-objc-init-message-with-info (instance init-info args)
    2260   (let* ((selector (objc-init-message-info-selector init-info))
    2261          (alist (objc-init-message-info-method-signature-alist init-info))
    2262          (pair (do* ((alist alist (cdr alist)))
    2263                     ((null (cdr alist))
    2264                      (car alist)
    2265                      (let* ((pair (car alist)))
    2266                        (dolist (class (cdr pair))
    2267                          (when (typep instance class)
    2268                            (return pair))))))))
    2269     (with-ns-exceptions-as-errors
    2270         (apply (objc-init-method-signature-info-function (car pair))
    2271                instance
    2272                selector
    2273                args))))
     2461
     2462
Note: See TracChangeset for help on using the changeset viewer.