Changeset 5889


Ignore:
Timestamp:
Feb 10, 2007, 11:00:08 PM (18 years ago)
Author:
Gary Byers
Message:

Pointer comparisons in splay trees use %ptr<, to hide word-size differences.

NSConstantStringClassReference isn't what it used to be, so look up
NSConstantStringClass the hard way.

Handle ns-exception/lisp-error stuff on x86-64.

Do arg/result coercions differently. Does any code depend on
COERCE-TO-ADDRESS behavior ? (It can cause extra consing of MACPTRs).

Use the new FFI interface for message-sends, callbacks to try to
hide platform-specific ABI issues.

The _deallocate-hook mechanism - which never really worked - probably
can't work on Objc-2.0.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/ccl/examples/objc-runtime.lisp

    r5865 r5889  
    108108
    109109
    110 (let* ((objc-class-map (make-splay-tree #'%ptr-eql
    111                                         #'(lambda (x y)
    112                                             (< (the (unsigned-byte 32)
    113                                                  (%ptr-to-int x))
    114                                                (the (unsigned-byte 32)
    115                                                  (%ptr-to-int Y))))))
    116        (objc-metaclass-map (make-splay-tree #'%ptr-eql
    117                                             #'(lambda (x y)
    118                                                 (< (the (unsigned-byte 32)
    119                                                      (%ptr-to-int x))
    120                                                    (the (unsigned-byte 32)
    121                                                      (%ptr-to-int Y))))))
     110(defun %ptr< (x y)
     111  (< (the (unsigned-byte #+64-bit-target 64 #+32-bit-target 32)
     112       (%ptr-to-int x))
     113     (the (unsigned-byte #+64-bit-target 64 #+32-bit-target 32)
     114       (%ptr-to-int Y))))
     115
     116(let* ((objc-class-map (make-splay-tree #'%ptr-eql #'%ptr<))
     117       (objc-metaclass-map (make-splay-tree #'%ptr-eql #'%ptr<))
    122118       ;;; These are NOT lisp classes; we mostly want to keep track
    123119       ;;; of them so that we can pretend that instances of them
    124120       ;;; are instances of some known (declared) superclass.
    125        (private-objc-classes (make-splay-tree #'%ptr-eql
    126                                               #'(lambda (x y)
    127                                                   (< (the (unsigned-byte 32)
    128                                                        (%ptr-to-int x))
    129                                                      (the (unsigned-byte 32)
    130                                                        (%ptr-to-int Y))))))
     121       (private-objc-classes (make-splay-tree #'%ptr-eql #'%ptr<))
    131122       (objc-class-lock (make-lock))
    132123       (next-objc-class-id 0)
    133124       (next-objc-metaclass-id 0)
    134125       (class-table-size 1024)
    135        (c (make-array 1024))
    136        (m (make-array 1024))
     126       (c (make-array class-table-size))
     127       (m (make-array class-table-size))
    137128       (cw (make-array 1024 :initial-element nil))
    138129       (mw (make-array 1024 :initial-element nil))
    … …  
    289280
    290281;;; Open shared libs.
    291 #+darwinppc-target
     282#+darwin-target
    292283(progn
    293284(defloadvar *cocoa-event-process* *initial-process*)
    … …  
    438429
    439430(defloadvar *NSConstantString-class*
    440    #+apple-objc
    441   (foreign-symbol-address "__NSConstantStringClassReference")
    442   #+gnu-objc
    443431  (with-cstrs ((name "NSConstantString"))
    444       (#_objc_lookup_class name)))
     432    #+apple-objc (#_objc_lookUpClass name)
     433    #+gnu-objc (#_objc_lookup_class name)))
    445434
    446435
    … …  
    473462(defconstant JMP-r14 #x18 "offset of r14 (which we clobber) in jmp_buf")
    474463(defconstant JMP-r15 #x20 "offset of r15 (which we also clobber) in jmp_buf"))
     464
     465;;; These constants also come from Libc sources.  Hey, who needs
     466;;; header files ?
     467#+x8664-target
     468(progn
     469(defconstant JB-RBX 0)
     470(defconstant JB-RBP 8)
     471(defconstant JB-RSP 16)
     472(defconstant JB-R12 24)
     473(defconstant JB-R13 32)
     474(defconstant JB-R14 40)
     475(defconstant JB-R15 48)
     476(defconstant JB-RIP 56)
     477(defconstant JB-RFLAGS 64)
     478(defconstant JB-MXCSR 72)
     479(defconstant JB-FPCONTROL 76)
     480(defconstant JB-MASK 80)
     481)
     482
     483
    475484 
    476485
    … …  
    484493;;; place.
    485494
     495#+ppc-target
    486496(macrolet ((ppc-lap-word (instruction-form)
    487497             (uvref (uvref (compile nil
    … …  
    503513        p)))
    504514
     515#+x8664-target
     516(defloadvar *setjmp-catch-rip-code*
     517    (let* ((code-bytes '(#x4c #x89 #xe6     ; movq %r12, %rsi
     518                         #xff #xd3))        ; call *%rbx
     519           (nbytes (length code-bytes))
     520           (p (malloc nbytes)))
     521      (dotimes (i nbytes p)
     522        (setf (%get-unsigned-byte p i) (pop code-bytes)))))
     523         
     524
    505525;;; Catch frames are allocated on a stack, so it's OK to pass their
    506526;;; addresses around to foreign code.
    … …  
    515535;;; an empty C stack frame from which the callback will be called.
    516536
     537#+ppc-target
    517538(defun %associate-jmp-buf-with-catch-frame (jmp-buf catch-frame c-frame)
    518539  (%set-object jmp-buf JMP-sp c-frame)
    … …  
    523544        (%get-ptr jmp-buf JMP-r14) throw-to-catch-frame)
    524545  t)
     546
     547#+x8664-target
     548(defun %associate-jmp-buf-with-catch-frame (jmp-buf catch-frame c-frame)
     549  (setf (%get-ptr jmp-buf JB-rbx) throw-to-catch-frame
     550        (%get-ptr jmp-buf JB-rip) *setjmp-catch-rip-code*)
     551  (%set-object jmp-buf JB-RSP c-frame)
     552  (%set-object jmp-buf JB-RBP c-frame)
     553  (%set-object jmp-buf JB-r12 catch-frame)
     554  t)
     555
    525556
    526557)
    … …  
    962993;;;   - Lisp numbers  => SINGLE-FLOAT when possible
    963994
    964 (defmacro coerce-to-bool (x)
     995(defun coerce-to-bool (x)
    965996  (let ((x-temp (gensym)))
    966997    `(let ((,x-temp ,x))
    967        (if (or (eq ,x-temp 0) (null ,x-temp)) #.#$NO #.#$YES))))
    968 
    969 (defmacro coerce-to-address (x)
     998       (if (or (eq ,x-temp 0) (null ,x-temp))
     999         #.#$NO
     1000         #.#$YES))))
     1001
     1002(declaim (inline %coerce-to-bool))
     1003(defun %coerce-to-bool (x)
     1004  (if (and x (not (eql x 0)))
     1005    #$YES
     1006    #$NO))
     1007
     1008(defun coerce-to-address (x)
    9701009  (let ((x-temp (gensym)))
    9711010    `(let ((,x-temp ,x))
    … …  
    9741013             (t ,x-temp)))))
    9751014
    976 (defmacro coerce-to-foreign-type (x ftype)
     1015;;; This is generally a bad idea; it forces us to
     1016;;; box intermediate pointer arguments in order
     1017;;; to typecase on them, and it's not clear to
     1018;;; me that it offers much in the way of additional
     1019;;; expressiveness.
     1020(declaim (inline %coerce-to-address))
     1021(defun %coerce-to-address (x)
     1022  (etypecase x
     1023    (macptr x)
     1024    (string (%make-nsstring x))         ; does this ever get released ?
     1025    (null (%null-ptr))))
     1026
     1027(defun coerce-to-foreign-type (x ftype)
    9771028   (cond ((and (constantp x) (constantp ftype))
    9781029          (case ftype
    … …  
    9821033         ((constantp ftype)
    9831034          (case ftype
    984             (:id `(coerce-to-address ,x))
    985             (:<BOOL> `(coerce-to-bool ,x))
     1035            (:id `(%coerce-to-address ,x))
     1036            (:<BOOL> `(%coerce-to-bool ,x))
    9861037            (t x)))
    9871038         (t `(case ,(if (atom ftype) ftype)
    988                (:id (coerce-to-address ,x))
    989                (:<BOOL> (coerce-to-bool ,x))
     1039               (:id (%coerce-to-address ,x))
     1040               (:<BOOL> (%coerce-to-bool ,x))
    9901041               (t ,x)))))
    9911042
    9921043(defun objc-arg-coerce (typespec arg)
    993   (coerce-to-foreign-type arg typespec))
     1044  (case typespec
     1045    (:<BOOL> `(%coerce-to-bool ,arg))
     1046    (:id `(%coerce-to-address ,arg))
     1047    (t arg)))
    9941048
    9951049
    … …  
    10351089  #+apple-objc
    10361090  (funcall (ftd-ff-call-expand-function *target-ftd*)
    1037            `(external-call "_objc_msgSend")
    1038            `(:id ,receiver :<SEL> (@selector ,selector-name) ,@argspecs)
     1091           `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSend"))))
     1092           `(:address ,receiver :<SEL> (@selector ,selector-name) ,@argspecs)
    10391093           :arg-coerce 'objc-arg-coerce
    10401094           :result-coerce 'objc-result-coerce) 
    … …  
    10511105      (funcall (ftd-ff-call-expand-function *target-ftd*)
    10521106       `(%ff-call ,imp)
    1053        `(:id ,receiver :<SEL> (@selector ,selector-name) ,@argspecs)
     1107       `(:address ,receiver :<SEL> (@selector ,selector-name) ,@argspecs)
    10541108       :arg-coerce 'objc-arg-coerce
    10551109       :result-coerce 'objc-result-coerce))))
    … …  
    10841138           (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec)
    10851139                         "_objc_msgSend_stret"
    1086                          "_objc-msgSend")))
     1140                         "_objc_msgSend")))
    10871141      (funcall (ftd-ff-call-expand-function *target-ftd*)
    1088                `(%ff-call (external ,entry-name))
    1089                `(,structptr :id ,receiver :<SEL> (@selector ,selector-name) ,@argspecs)
     1142               `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name))))
     1143        `(,structptr :address ,receiver :<SEL> (@selector ,selector-name) ,@argspecs)
    10901144               :arg-coerce 'objc-arg-coerce
    10911145               :result-coerce 'objc-result-coerce))
    … …  
    11021156      ,      (funcall (ftd-ff-call-expand-function *target-ftd*)
    11031157               `(%ff-call ,imp)
    1104               `(,structptr :id , :<SEL> ,s ,@argspecs)
     1158              `(,structptr :address ,receiver :<SEL> ,s ,@argspecs)
    11051159               :arg-coerce 'objc-arg-coerce
    11061160               :result-coerce 'objc-result-coerce))))
    … …  
    11151169  #+apple-objc
    11161170  (funcall (ftd-ff-call-expand-function *target-ftd*)
    1117            `(%ff-call (external "_objc_msgSendSuper"))
     1171           `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSendSuper"))))
    11181172           `(:address ,super :<SEL> (@selector ,selector-name) ,@argspecs)
    11191173           :arg-coerce 'objc-arg-coerce
    … …  
    11421196           (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec)
    11431197                         "_objc_msgSendSuper_stret"
    1144                          "_objc-msgSendSuper")))
     1198                         "_objc_msgSendSuper")))
    11451199      (funcall (ftd-ff-call-expand-function *target-ftd*)
    1146                `(%ff-call (external ,entry-name))
     1200               `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name))))
    11471201               `(,structptr :address ,super :<SEL> (@selector ,selector-name) ,@argspecs)
    11481202               :arg-coerce 'objc-arg-coerce
    … …  
    11761230  )
    11771231
     1232
     1233
    11781234;;; The first 13 fp arguments get passed in F1-F13 (and also "consume"
    11791235;;; a GPR or two.)  It's certainly possible for an FP arg and a non-
    11801236;;; FP arg to share the same "offset", and parameter offsets aren't
    11811237;;; strictly increasing.
     1238#+ppc-target
    11821239(defvar *objc-fpr-offsets*
    11831240  #+32-bit-target
    … …  
    12571314                 (format nil "^~a" (encode-objc-type element-type))))))
    12581315          (t (break "type = ~s" type)))))))
    1259                  
     1316
     1317#+ppc-target
    12601318(defun encode-objc-method-arglist (arglist result-spec)
    12611319  (let* ((gprs-used 0)
    … …  
    12841342                       (incf gprs-used 2))
    12851343                      (foreign-single-float-type
    1286                        (setq size 4 offset (current-fpr-arg-offset))
     1344                       (setq size target::node-size offset (current-fpr-arg-offset))
    12871345                       (incf fprs-used)
    12881346                       (incf gprs-used 1))
    … …  
    12941352                         (setq size (ceiling bits 8)
    12951353                               offset (current-gpr-arg-offset))
    1296                          (incf gprs-used (ceiling bits 32))))
     1354                         (incf gprs-used (ceiling bits target::nbits-in-word))))
    12971355                      ((or foreign-record-type foreign-array-type)
    12981356                       (let* ((bits (ensure-foreign-type-bits arg)))
    12991357                         (setq size (ceiling bits 8)
    13001358                               offset (current-gpr-arg-offset))
    1301                          (incf gprs-used (ceiling bits 32))))
     1359                         (incf gprs-used (ceiling bits target::nbits-in-word))))
    13021360                      (t (break "argspec = ~s, arg = ~s" argspec arg)))
    13031361                    (push (list (encode-objc-type arg) offset size) result))))))))
    … …  
    13071365                                    arg-info))
    13081366               objc-forwarding-stack-offset)))
     1367      (format nil "~a~d~:{~a~d~}"
     1368              (encode-objc-type
     1369               (parse-foreign-type result-spec))
     1370              max-parm-end
     1371              arg-info))))
     1372
     1373#+x8664-target
     1374(defun encode-objc-method-arglist (arglist result-spec)
     1375  (let* ((offset 0)
     1376         (arg-info
     1377          (let* ((result nil))
     1378                (dolist (argspec arglist (nreverse result))
     1379                  (let* ((arg (parse-foreign-type argspec))
     1380                         (delta 8))
     1381                    (typecase arg
     1382                      (foreign-double-float-type)
     1383                      (foreign-single-float-type)
     1384                      ((or foreign-pointer-type foreign-array-type))
     1385                      (foreign-integer-type)
     1386                      (foreign-record-type
     1387                       (let* ((bits (ensure-foreign-type-bits arg)))
     1388                         (setq delta (ceiling bits 8))))
     1389                      (t (break "argspec = ~s, arg = ~s" argspec arg)))
     1390                    (push (list (encode-objc-type arg) offset) result)
     1391                    (setq offset (* 8 (ceiling (+ offset delta) 8))))))))
     1392    (let* ((max-parm-end offset))
    13091393      (format nil "~a~d~:{~a~d~}"
    13101394              (encode-objc-type
    … …  
    15371621          (call type)
    15381622          (case type
    1539             (:<BOOL> (call `(coerce-to-bool ,arg)))
    1540             (:id (call `(coerce-to-address ,arg)))
     1623            (:<BOOL> (call `(%coerce-to-bool ,arg)))
     1624            (:id (call `(%coerce-to-address ,arg)))
    15411625            (otherwise (call arg)))))
    15421626      ;; all "init" messages return :id
    … …  
    16081692      init-info)))
    16091693
    1610 (defun send-init-message-with-info (instance init-info args)
    1611   (let* ((selector (objc-init-message-info-selector init-info))
    1612          (alist (objc-init-message-info-method-signature-alist init-info))
    1613          (pair (do* ((alist alist (cdr alist)))
    1614                     ((null (cdr alist))
    1615                      (car alist)
    1616                      (let* ((pair (car alist)))
    1617                        (dolist (class (cdr pair))
    1618                          (when (typep instance class)
    1619                            (return pair))))))))
    1620     (with-ns-exceptions-as-errors
    1621         (apply (objc-init-method-signature-info-function (car pair))
    1622                instance
    1623                selector
    1624                args))))
     1694
    16251695                                                       
    16261696
    … …  
    16401710  "Maps from lists of init keywords to OBJC-INIT-MESSAGE structures")
    16411711
    1642 (defun send-objc-init-message-with-info (instance init-info args)
    1643   (let* ((selector (objc-init-message-info-selector init-info))
    1644          (alist (objc-init-message-info-method-signature-alist init-info))
    1645          (pair (do* ((alist alist (cdr alist)))
    1646                     ((null (cdr alist))
    1647                      (car alist)
    1648                      (let* ((pair (car alist)))
    1649                        (dolist (class (cdr pair))
    1650                          (when (typep instance class)
    1651                            (return pair))))))))
    1652     (with-ns-exceptions-as-errors
    1653         (apply (objc-init-method-signature-info-function (car pair))
    1654                instance
    1655                selector
    1656                args))))
     1712
     1713
     1714
    16571715
    16581716
    … …  
    16681726    (send-objc-init-message-with-info instance info args)))   
    16691727                   
    1670 (defun allocate-objc-object (class)
    1671   (send class 'alloc))
     1728
    16721729 
    16731730
    … …  
    20692126  #+gnu-objc (#_method_get_number_of_arguments m))
    20702127
    2071 #+apple-objc
     2128#+(and apple-objc (not apple-objc-2.0))
    20722129(progn
    20732130(defloadvar *original-deallocate-hook*
    … …  
    21182175    `(let ((,pool-temp (create-autorelease-pool)))
    21192176      (unwind-protect
    2120            ,@body
     2177           (progn ,@body)
    21212178        (release-autorelease-pool ,pool-temp)))))
    21222179
    … …  
    21372194        (:pointers (:array :address 4)))))
    21382195
    2139 ;;; Apple's mechanism for maintaining per-thread exception handler
    2140 ;;; state isn't thread safe, which suggests that we should probably
    2141 ;;; install our own callbacks via #_objc_exception_set_functions.
    2142 ;;; It's 2007.
    21432196
    21442197#+apple-objc-2.0
    … …  
    21502203           (progn
    21512204             (#_objc_exception_try_enter ,data)
    2152                (catch ,data
     2205             (catch ,data
    21532206               (with-c-frame ,cframe
    21542207                 (%associate-jmp-buf-with-catch-frame
    … …  
    22012254
    22022255
     2256(defun send-objc-init-message-with-info (instance init-info args)
     2257  (let* ((selector (objc-init-message-info-selector init-info))
     2258         (alist (objc-init-message-info-method-signature-alist init-info))
     2259         (pair (do* ((alist alist (cdr alist)))
     2260                    ((null (cdr alist))
     2261                     (car alist)
     2262                     (let* ((pair (car alist)))
     2263                       (dolist (class (cdr pair))
     2264                         (when (typep instance class)
     2265                           (return pair))))))))
     2266    (with-ns-exceptions-as-errors
     2267        (apply (objc-init-method-signature-info-function (car pair))
     2268               instance
     2269               selector
     2270               args))))
Note: See TracChangeset for help on using the changeset viewer.