Changeset 450


Ignore:
Timestamp:
Feb 1, 2004, 5:17:45 AM (21 years ago)
Author:
Gary Byers
Message:

More than one class can share the same metaclass.

Location:
trunk/ccl/examples
Files:
2 edited

Legend:

Unmodified
Added
Removed

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

    r434 r450  
    4747(package-force-export "NS")
    4848
     49(defparameter *objc-import-private-ivars* t "When true, the CLASS-DIRECT-SLOTS of imported ObjC classes will contain slot definitions for instance variables whose name starts with an underscore.  Note that this may exacerbate compatibility problems.")
     50
    4951;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    5052;;;;                                 Testing                                ;;;;
    … …  
    8082
    8183(defvar *objc-object-slot-vectors* (make-hash-table :test #'eql))
     84(defvar *objc-canonical-instances* (make-hash-table :test #'eql :weak :value))
     85
     86(defun raw-macptr-for-instance (instance)
     87  (let* ((p (%null-ptr)))
     88    (%set-macptr-domain p 1)            ; not an ObjC object, but EQL to one
     89    (%setf-macptr p instance)
     90    p))
     91
     92(defun register-canonical-objc-instance (instance raw-ptr)
     93  ;(terminate-when-unreachable instance)
     94  ;(retain-objc-instance instance)
     95  (setf (gethash raw-ptr *objc-canonical-instances*) instance))
     96
     97(defun canonicalize-objc-instance (instance)
     98  (or (gethash instance *objc-canonical-instances*)
     99      (register-canonical-objc-instance
     100       (setq instance (%inc-ptr instance 0))
     101       (raw-macptr-for-instance instance))))
    82102
    83103(defun recognize-objc-object (p)
    … …  
    97117    (ecase flags
    98118      (#.objc-flag-instance (id->objc-class index))
    99       (#.objc-flag-class (id->objc-metaclass index))
     119      (#.objc-flag-class (objc-class-id->objc-metaclass index))
    100120      (#.objc-flag-metaclass *objc-metaclass-class*))))
    101121 
    … …  
    113133    (ecase flags
    114134      (#.objc-flag-instance (id->objc-class-wrapper index))
    115       (#.objc-flag-class (id->objc-metaclass-wrapper index))
     135      (#.objc-flag-class (id->objc-metaclass-wrapper (objc-class-id->objc-metaclass-id index)))
    116136      (#.objc-flag-metaclass (%class.own-wrapper *objc-metaclass-class*)))))
    117137
    … …  
    197217(defmethod print-object ((o objc:objc-object) stream)
    198218  (print-unreadable-object (o stream :type t)
    199     (format stream "~a (#x~x)" (nsobject-description o) (%ptr-to-int o))))
     219    (format stream
     220            (if (typep o 'ns::ns-string)
     221              "~s (#x~x)"
     222              "~a (#x~x)")
     223            (nsobject-description o) (%ptr-to-int o))))
    200224
    201225
    … …  
    301325    (with-macptrs ((ivars (pref c :objc_class.ivars)))
    302326      (unless (%null-ptr-p ivars)
    303         (loop with ns-package = (find-package "NS")
    304               with n = (pref ivars :objc_ivar_list.ivar_count)
    305               with state = (make-ivar-parse-state c)
    306               for i from 1 to n
    307               for ivar = (pref ivars :objc_ivar_list.ivar_list)
    308                   then (%inc-ptr ivar (record-length :objc_ivar))
    309               for name = (%get-cstring (pref ivar :objc_ivar.ivar_name))
    310               for sym = (compute-lisp-name name ns-package)
    311               when (eql (schar name 0) #\_)
    312                 do (unexport sym ns-package)
    313               ;do (format t "~S: ~S~%" name (pref ivar :objc_ivar.ivar_offset))
    314               collect
    315               (make-direct-slot-definition-from-ivar
    316                state
    317                (pref ivar :objc_ivar.ivar_offset)
    318                (with-string-from-cstring
    319                           (s (pref ivar :objc_ivar.ivar_type))
    320                         (objc-foreign-type-for-ivar s))
    321                c
    322                (list
    323                 :name sym
    324                 :allocation :instance
    325                 :class c )))))))
     327        (let* ((ns-package (find-package "NS"))
     328               (n (pref ivars :objc_ivar_list.ivar_count))
     329               (state (make-ivar-parse-state c)))
     330          (collect ((dslotds))
     331            (do* ((i 0 (1+ i))
     332                  (ivar (pref ivars :objc_ivar_list.ivar_list)
     333                        (%inc-ptr ivar (record-length :objc_ivar))))
     334                 ((= i n) (dslotds))
     335              (declare (fixnum i))
     336              (with-macptrs ((nameptr (pref ivar :objc_ivar.ivar_name)))
     337                (let* ((is-private (eql (%get-unsigned-byte nameptr 0)
     338                                    (char-code #\_))))
     339                  (when (or (not is-private)
     340                            *objc-import-private-ivars*)
     341                    (let* ((name (%get-cstring nameptr))
     342                           (sym (compute-lisp-name name ns-package)))
     343                      (when is-private
     344                        (unexport sym ns-package))
     345                      (dslotds
     346                       (make-direct-slot-definition-from-ivar
     347                        state
     348                        (pref ivar :objc_ivar.ivar_offset)
     349                        (with-string-from-cstring
     350                            (s (pref ivar :objc_ivar.ivar_type))
     351                          (objc-foreign-type-for-ivar s))
     352                        c
     353                        (list
     354                         :name sym
     355                         :allocation :instance
     356                         :class c ))))))))))))))
    326357
    327358(defun make-direct-slot-definition-from-ivar (state
    … …  
    493524       (values #'%get-single-float #'%set-single-float))
    494525      (foreign-pointer-type
    495        (values #'%get-ptr #'%set-ptr))
     526       ;; If we're pointing to a structure whose first field is
     527       ;; a pointer to a structure named :OBJC_CLASS, we're of
     528       ;; type :ID and can (fairly) safely use %GET-PTR.
     529       ;; Otherwise, reference the field as a raw  macptr.
     530       (let* ((to (foreign-pointer-type-to ftype)))
     531         (if
     532           (and (typep to 'foreign-record-type)
     533                (eq :struct (foreign-record-type-kind to))
     534                (progn
     535                  (ensure-foreign-type-bits to)
     536                  (let* ((first-field (car (foreign-record-type-fields to)))
     537                         (first-field-type
     538                          (if first-field
     539                            (foreign-record-field-type first-field))))
     540                    (and (typep first-field-type 'foreign-pointer-type)
     541                         (let* ((first-to (foreign-pointer-type-to
     542                                           first-field-type)))
     543                           (and (typep first-to 'foreign-record-type)
     544                                (eq :struct
     545                                    (foreign-record-type-kind first-to))
     546                                (eq :objc_class
     547                                    (foreign-record-type-name first-to))))))))
     548           (values #'%get-ptr #'%set-ptr)
     549           (values #'(lambda (ptr offset)
     550                       (let* ((p (%null-ptr)))
     551                         (%set-macptr-domain p 1)
     552                         (%setf-macptr p (%get-ptr ptr offset))))
     553                   #'%set-ptr))))
    496554      (foreign-mem-block-type
    497555       (let* ((nbytes (%foreign-type-or-record-size ftype :bytes)))
    … …  
    661719    (unless (%null-ptr-p instance)
    662720      (let* ((len (length (%wrapper-instance-slots (class-own-wrapper class))))
     721             (raw-ptr (raw-macptr-for-instance instance))
    663722             (slot-vector
    664723              (unless (zerop len)
    665724                (allocate-typed-vector :slot-vector (1+ len) (%slot-unbound-marker)))))
    666         (setf (slot-vector.instance slot-vector) instance)
    667         (setf (gethash instance *objc-object-slot-vectors*) slot-vector)
    668         (terminate-when-unreachable instance)
    669         (retain-obcj-object instance)
    670         instance))))
     725        (setf (slot-vector.instance slot-vector) raw-ptr)
     726        (register-canonical-objc-instance instance raw-ptr)))))
    671727
    672728(defmethod terminate ((instance objc:objc-object))

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

    r433 r450  
    6868
    6969
    70 ;                        (let* ((metaclass-name (intern (concatenate 'string "+" (string class-name)) (symbol-package class-name)))
    71 
    7270
    7371(let* ((objc-class-map (make-splay-tree #'%ptr-eql
    … …  
    8583       (objc-class-lock (make-lock))
    8684       (next-objc-class-id 0)
     85       (next-objc-metaclass-id 0)
    8786       (class-table-size 1024)
    8887       (c (make-array 1024))
    … …  
    9190       (mw (make-array 1024 :initial-element nil))
    9291       (csv (make-array 1024))
    93        (msv (make-array 1024)))
    94 
    95   (flet ((assign-next-class-id ()
    96            (let* ((id next-objc-class-id))
    97              (if (= (incf next-objc-class-id) class-table-size)
    98                (let* ((old-size class-table-size)
    99                       (new-size (* 2 class-table-size)))
    100                  (declare (fixnum old-size new-size))
    101                  (macrolet ((extend (v)
     92       (msv (make-array 1024))
     93       (class-id->metaclass-id (make-array 1024 :initial-element nil)))
     94
     95  (flet ((grow-vectors ()
     96           (let* ((old-size class-table-size)
     97                  (new-size (* 2 old-size)))
     98             (declare (fixnum old-size new-size))
     99             (macrolet ((extend (v)
    102100                              `(setq ,v (%extend-vector old-size ,v new-size))))
    103101                   (extend c)
    … …  
    105103                   (extend cw)
    106104                   (extend mw)
     105                   (fill cw nil :start old-size :end new-size)
     106                   (fill mw nil :start old-size :end new-size)
    107107                   (extend csv)
    108                    (extend msv))
    109                  (setq class-table-size new-size)))
    110              id)))
    111     (defun id->objc-class (i)
    112       (svref c i))
    113     (defun (setf id->objc-class) (new i)
    114       (setf (svref c i) new))
    115     (defun id->objc-metaclass (i)
    116       (svref m i))
    117     (defun (setf id->objc-metaclass) (new i)
    118       (setf (svref m i) new))
    119     (defun id->objc-class-wrapper (i)
    120       (svref cw i))
    121     (defun (setf id->objc-class-wrapper) (new i)
    122       (setf (svref cw i) new))
    123     (defun id->objc-metaclass-wrapper (i)
    124       (svref mw i))
    125     (defun (setf id->objc-metaclass-wrapper) (new i)
    126       (setf (svref mw i) new))
    127     (defun id->objc-class-slots-vector (i)
    128       (svref csv i))
    129     (defun (setf id->objc-class-slots-vector) (new i)
    130       (setf (svref csv i) new))
    131     (defun id->objc-metaclass-slots-vector (i)
    132       (svref msv i))
    133     (defun (setf id->objc-metaclass-slots-vector) (new i)
    134       (setf (svref msv i) new))
    135    
    136     (defun %clear-objc-class-maps ()
    137       (with-lock-grabbed (objc-class-lock)
    138         (fill c 0)
    139         (fill m 0)
    140         (fill cw 0)
    141         (fill mw 0)
    142         (fill csv 0)
    143         (fill msv 0)
    144         (setf (splay-tree-root objc-class-map) nil
    145               (splay-tree-root objc-metaclass-map) nil
    146               (splay-tree-count objc-class-map) 0
    147               (splay-tree-count objc-metaclass-map) 0
    148               next-objc-class-id 0)))
    149 
    150     (defun register-objc-class (class)
    151       "ensure that the class (and metaclass) are mapped to a small integer,
    152 and that each have slots-vectors associated with them."
    153       (with-lock-grabbed (objc-class-lock)
    154         (ensure-objc-classptr-resolved class)
    155         (or (splay-tree-get objc-class-map class)
    156             (let* ((id (assign-next-class-id))
    157                    (class (%inc-ptr class 0))
    158                    (meta (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer)))
    159               (splay-tree-put objc-class-map class id)
    160               (splay-tree-put objc-metaclass-map meta id)
    161               (setf (svref c id) class
    162                     (svref m id) meta
    163                     (svref csv id)
    164                     (make-objc-class-slots-vector class)
    165                     (svref msv id)
    166                     (make-objc-metaclass-slots-vector meta))
    167               id))))
    168     (defun objc-class-id (class)
    169       (with-lock-grabbed (objc-class-lock)
    170         (splay-tree-get objc-class-map class)))
    171     (defun objc-metaclass-id (meta)
    172       (with-lock-grabbed (objc-class-lock)
    173         (splay-tree-get objc-metaclass-map meta)))
    174     (defun objc-class-map () objc-class-map)
    175     (defun objc-metaclass-map () objc-metaclass-map)))
     108                   (extend msv)
     109                   (extend class-id->metaclass-id)
     110                   (fill class-id->metaclass-id nil :start old-size :end new-size))
     111             (setq class-table-size new-size))))
     112    (flet ((assign-next-class-id ()
     113             (let* ((id next-objc-class-id))
     114               (if (= (incf next-objc-class-id) class-table-size)
     115                 (grow-vectors))
     116               id))
     117           (assign-next-metaclass-id ()
     118             (let* ((id next-objc-metaclass-id))
     119               (if (= (incf next-objc-metaclass-id) class-table-size)
     120                 (grow-vectors))
     121               id)))
     122      (defun id->objc-class (i)
     123        (svref c i))
     124      (defun (setf id->objc-class) (new i)
     125        (setf (svref c i) new))
     126      (defun id->objc-metaclass (i)
     127        (svref m i))
     128      (defun (setf id->objc-metaclass) (new i)
     129        (setf (svref m i) new))
     130      (defun id->objc-class-wrapper (i)
     131        (svref cw i))
     132      (defun (setf id->objc-class-wrapper) (new i)
     133        (setf (svref cw i) new))
     134      (defun id->objc-metaclass-wrapper (i)
     135        (svref mw i))
     136      (defun (setf id->objc-metaclass-wrapper) (new i)
     137        (setf (svref mw i) new))
     138      (defun id->objc-class-slots-vector (i)
     139        (svref csv i))
     140      (defun (setf id->objc-class-slots-vector) (new i)
     141        (setf (svref csv i) new))
     142      (defun id->objc-metaclass-slots-vector (i)
     143        (svref msv i))
     144      (defun (setf id->objc-metaclass-slots-vector) (new i)
     145        (setf (svref msv i) new))
     146      (defun %clear-objc-class-maps ()
     147        (with-lock-grabbed (objc-class-lock)
     148          (fill c 0)
     149          (fill m 0)
     150          (fill cw nil)
     151          (fill mw nil)
     152          (fill csv 0)
     153          (fill msv 0)
     154          (fill class-id->metaclass-id nil)
     155          (setf (splay-tree-root objc-class-map) nil
     156                (splay-tree-root objc-metaclass-map) nil
     157                (splay-tree-count objc-class-map) 0
     158                (splay-tree-count objc-metaclass-map) 0
     159                next-objc-class-id 0
     160                next-objc-metaclass-id 0)))
     161      (flet ((install-objc-metaclass (meta)
     162               (or (splay-tree-get objc-metaclass-map meta)
     163                   (let* ((id (assign-next-metaclass-id))
     164                          (meta (%inc-ptr meta 0)))
     165                     (splay-tree-put objc-metaclass-map meta id)
     166                     (setf (svref m id) meta
     167                           (svref msv id)
     168                           (make-objc-metaclass-slots-vector meta))
     169                     id))))
     170        (defun register-objc-class (class)
     171          "ensure that the class is mapped to a small integer and associate a slots-vector with it."
     172          (with-lock-grabbed (objc-class-lock)
     173            (ensure-objc-classptr-resolved class)
     174            (or (splay-tree-get objc-class-map class)
     175                (let* ((id (assign-next-class-id))
     176                       (class (%inc-ptr class 0))
     177                       (meta (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer)))
     178                  (splay-tree-put objc-class-map class id)
     179                  (setf (svref c id) class
     180                        (svref csv id)
     181                        (make-objc-class-slots-vector class)
     182                        (svref class-id->metaclass-id id)
     183                        (install-objc-metaclass meta))
     184                  id)))))
     185      (defun objc-class-id (class)
     186        (with-lock-grabbed (objc-class-lock)
     187          (splay-tree-get objc-class-map class)))
     188      (defun objc-metaclass-id (meta)
     189        (with-lock-grabbed (objc-class-lock)
     190          (splay-tree-get objc-metaclass-map meta)))
     191      (defun objc-class-id->objc-metaclass-id (class-id)
     192        (svref class-id->metaclass-id class-id))
     193      (defun objc-class-id->objc-metaclass (class-id)
     194        (svref m (svref class-id->metaclass-id class-id)))
     195      (defun objc-class-map () objc-class-map)
     196      (defun objc-metaclass-map () objc-metaclass-map))))
    176197
    177198(pushnew #'%clear-objc-class-maps *save-exit-functions* :test #'eq
    … …  
    235256(pushnew 'remap-all-library-classes *lisp-system-pointer-functions*)
    236257
     258(let* ((cfstring-sections (cons 0 nil)))
     259  (defun reset-cfstring-sections ()
     260    (rplaca cfstring-sections 0)
     261    (rplacd cfstring-sections nil))
     262  (defun find-cfstring-sections ()
     263    (let* ((image-count (#_ _dyld_image_count)))
     264      (when (> image-count (car cfstring-sections))
     265        (process-section-in-all-libraries
     266         #$SEG_DATA
     267         "__cfstring"
     268         #'(lambda (sectaddr size)
     269             (let* ((addr (%ptr-to-int sectaddr))
     270                    (limit (+ addr size))
     271                    (already (member addr (cdr cfstring-sections) :key #'car)))
     272               (if already
     273                 (rplacd already limit)
     274                 (push (cons addr limit) (cdr cfstring-sections))))))
     275        (setf (car cfstring-sections) image-count))))
     276  (defun pointer-in-cfstring-section-p (ptr)
     277    (let* ((addr (%ptr-to-int ptr)))
     278      (dolist (s (cdr cfstring-sections))
     279        (when (and (>= addr (car s))
     280                   (< addr (cdr s)))
     281          (return t))))))
     282               
     283                                         
     284
    237285)
    238286
    … …  
    298346                                         (pref class :objc_class.name))
    299347                                        "NS"))
    300                (meta (id->objc-metaclass id))
    301                (meta-name (intern (concatenate 'string
    302                                                "+"
    303                                                (string class-name))
    304                                   "NS"))
    305                (meta-super (pref meta :objc_class.super_class)))
    306           ;; It's important (here and when initializing the class
    307           ;; below) to use the "canonical" (registered) version
    308           ;; of the class, since some things in CLOS assume
    309           ;; EQness.  We probably don't want to violate that
    310           ;; assumption; it'll be easier to revive a saved image
    311           ;; if we don't have a lot of EQL-but-not-EQ class pointers
    312           ;; to deal with.
    313           (initialize-instance meta
    314                                :name meta-name
    315                                :direct-superclasses
    316                                (list
    317                                 (if (or (%null-ptr-p meta-super)
    318                                         (not (%objc-metaclass-p meta-super)))
    319                                   (find-class 'objc:objc-class)
    320                                   (canonicalize-registered-metaclass meta-super)))
    321                                :peer class
    322                                :foreign t)
    323           (setf (find-class meta-name) meta)
    324 ;         (setf (id->objc-metaclass-wrapper id) (%class-own-wrapper meta))
     348               (meta-id (objc-class-id->objc-metaclass-id id))
     349               (meta (id->objc-metaclass meta-id)))
     350          ;; Metaclass may already be initialized.  It'll have a class
     351          ;; wrapper if so.
     352          (unless (id->objc-metaclass-wrapper meta-id)
     353            (let* ((meta-name (intern
     354                               (concatenate 'string
     355                                            "+"
     356                                            (string
     357                                             (objc-to-lisp-classname
     358                                              (%get-cstring
     359                                               (pref meta :objc_class.name))
     360                                              "NS")))
     361                                      "NS"))
     362                   (meta-super (pref meta :objc_class.super_class)))
     363              ;; It's important (here and when initializing the class
     364              ;; below) to use the "canonical" (registered) version
     365              ;; of the class, since some things in CLOS assume
     366              ;; EQness.  We probably don't want to violate that
     367              ;; assumption; it'll be easier to revive a saved image
     368              ;; if we don't have a lot of EQL-but-not-EQ class pointers
     369              ;; to deal with.
     370              (initialize-instance meta
     371                                   :name meta-name
     372                                   :direct-superclasses
     373                                   (list
     374                                    (if (or (%null-ptr-p meta-super)
     375                                            (not (%objc-metaclass-p meta-super)))
     376                                      (find-class 'objc:objc-class)
     377                                      (canonicalize-registered-metaclass meta-super)))
     378                                   :peer class
     379                                   :foreign t)
     380              (setf (find-class meta-name) meta)))
    325381          (setf (slot-value class 'direct-slots)
    326382                (%compute-foreign-direct-slots class))
    … …  
    334390                               :peer meta
    335391                               :foreign t)
    336 ;         (setf (id->objc-class-wrapper id) (%class-own-wrapper class))
    337392          (setf (find-class class-name) class))))))
    338393                               
    … …  
    919974           #+gnu-objc #$_CLS_META))
    920975           
     976(defun %objc-class-posing-p (class)
     977  (logtest (pref class :objc_class.info)
     978           #+apple-objc #$CLS_POSING
     979           #+gnu-objc #$_CLS_POSING))
    921980
    922981
    … …  
    9421001                 (%null-ptr)
    9431002                 0)))
    944            (meta (id->objc-metaclass id))
     1003           (meta (objc-class-id->objc-metaclass id))
    9451004           (class (id->objc-class id))
    9461005           (meta-name (intern (format nil "+~a" class-name)
    … …  
    9511010                         :name meta-name
    9521011                         :direct-superclasses (list meta-super))
    953     (setf ;(id->objc-metaclass-wrapper id) (%class-own-wrapper meta)
    954           (find-class meta-name) meta)
     1012      (setf (find-class meta-name) meta)
    9551013    class)))
    9561014
    … …  
    10291087(defun %objc-instance-class-index (p)
    10301088  #+apple-objc
    1031   (let* ((instance-apparent-size (zone-pointer-size p)))
    1032     (when (and instance-apparent-size (not (eql instance-apparent-size 0)))
    1033       (locally (declare (fixnum instance-apparent-size))
    1034           (with-macptrs ((parent (pref p :objc_object.isa)))
    1035             (let* ((idx (objc-class-id parent)))
    1036               (when idx
    1037                 (let* ((parent-size (if idx (pref parent :objc_class.instance_size))))
    1038                   (if (eql (- (ash (ash (the fixnum (+ parent-size 17)) -4) 4) 2)
    1039                            instance-apparent-size)
    1040                     idx)))))))))
     1089  (if (or (pointer-in-cfstring-section-p p)
     1090          (with-macptrs ((zone (#_malloc_zone_from_ptr p)))
     1091            (not (%null-ptr-p zone))))
     1092    (with-macptrs ((parent (pref p :objc_object.isa)))
     1093      (objc-class-id parent)))
    10411094  #+gnu-objc
    10421095  (with-macptrs ((parent (pref p objc_object.class_pointer)))
    10431096    (objc-class-id-parent))
     1097  )
    10441098
    10451099;;; If an instance, return (values :INSTANCE <class>).
    … …  
    13651419    (free obj)))
    13661420
     1421#+threads-problem
    13671422(def-ccl-pointers install-deallocate-hook ()
    13681423  (setf (%get-ptr (foreign-symbol-address "__dealloc")) deallocate-nsobject))
    … …  
    13931448")
    13941449
     1450
     1451(defun retain-objc-instance (instance)
     1452  (objc-message-send instance "retain"))
    13951453
    13961454;;; Execute BODY with an autorelease pool
Note: See TracChangeset for help on using the changeset viewer.