Changeset 10423


Ignore:
Timestamp:
Aug 10, 2008, 4:05:23 PM (11 years ago)
Author:
gb
Message:

Start setting class ordinals. Note that it's assumed that MAX-CLASS-ORDINAL
(1MB) is smaller than the value returned by (STRIP-TAG-TO-FIXNUM instance)
for any (heap-allocated) standard-instance.

Provide support for foreign-class-ordinals, though we don't yet implement
a foreign object domain that uses them.

Location:
trunk/source/level-1
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-clos-boot.lisp

    r10406 r10423  
    13401340
    13411341
     1342(defglobal *next-class-ordinal* 0)
     1343
     1344(defun %next-class-ordinal ()
     1345  (%atomic-incf-node 1 '*next-class-ordinal* target::symbol.vcell))
    13421346
    13431347;;; Initialized after built-in-class is made
     
    13471351  (%istruct 'class-ctype *class-type-class* nil class nil))
    13481352
    1349 
    1350 (defvar *t-class* (let* ((class (%cons-built-in-class 't))
    1351                          (wrapper (%cons-wrapper class (new-class-wrapper-hash-index)))
    1352                          (cpl (list class)))
    1353                     (setf (%class.cpl class) cpl)
    1354                     (setf (%wrapper-cpl wrapper) cpl)
    1355                     (setf (%class.own-wrapper class) wrapper)
    1356                     (setf (%class.ctype class) (make-class-ctype class))
    1357                     (setf (find-class 't) class)
    1358                     class))
     1353(defun %class-ordinal (class &optional no-error)
     1354  (if (standard-instance-p class)
     1355    (instance.hash class)
     1356    (if (typep class 'macptr)
     1357      (foreign-class-ordinal class)
     1358      (unless no-error
     1359        (error "Can't determine ordinal of ~s" class)))))
     1360
     1361(defun (setf %class-ordinal) (new class &optional no-error)
     1362  (if (standard-instance-p class)
     1363    (setf (instance.hash class) new)
     1364    (if (typep class 'macptr)
     1365      (setf (foreign-class-ordinal class) new)
     1366      (unless no-error
     1367        (error "Can't set ordinal of class ~s to ~s" class new)))))
     1368
     1369(defvar *t-class* (let* ((class (%cons-built-in-class 't)))
     1370                    (setf (instance.hash class) 0)
     1371                    (let* ((cpl (list class))
     1372                           (wrapper (%cons-wrapper class (new-class-wrapper-hash-index))))
     1373                      (setf (%class.cpl class) cpl)
     1374                      (setf (%wrapper-cpl wrapper) cpl)
     1375                      (setf (%class.own-wrapper class) wrapper)
     1376                      (setf (%class.ctype class) (make-class-ctype class))
     1377                      (setf (find-class 't) class)
     1378                      class)))
    13591379
    13601380(defun compute-cpl (class)
     
    13941414      cpl)))
    13951415
     1416(defun make-cpl-bits (cpl)
     1417  (when cpl
     1418    (let* ((max 0))
     1419      (declare (fixnum max))
     1420      (dolist (class cpl)
     1421        (let* ((ordinal (instance.hash class)))
     1422          (declare (fixnum ordinal))
     1423          (when (> ordinal max)
     1424            (setq max ordinal))))
     1425      (let* ((bits (make-array (the fixnum (1+ max)) :element-type 'bit)))
     1426        (dolist (class cpl bits)
     1427          (let* ((ordinal (instance.hash class)))
     1428            (setf (sbit bits ordinal) 1)))))))
     1429
     1430
    13961431(defun make-built-in-class (name &rest supers)
    13971432  (if (null supers)
     
    14061441        (dolist (sup (%class.local-supers class))
    14071442          (setf (%class.subclasses sup) (nremove class (%class.subclasses sup)))))
    1408       (setq class (%cons-built-in-class name)))
     1443      (progn
     1444        (setq class (%cons-built-in-class name))
     1445        (setf (instance.hash class) (%next-class-ordinal))))
    14091446    (dolist (sup supers)
    14101447      (setf (%class.subclasses sup) (cons class (%class.subclasses sup))))
     
    14411478                 (error "Attempt to remake standard class ~s" name)
    14421479                 (%cons-standard-class name metaclass-wrapper))))
     1480    (setf (instance.hash class) (%next-class-ordinal))
    14431481    (if (null supers)
    14441482      (setq supers (list *standard-class-class*))
     
    19702008                                          instance-class-wrapper
    19712009                                          class-own-wrapper
    1972                                           slots-vector)
     2010                                          slots-vector class-ordinal
     2011                                          set-class-ordinal)
    19732012    (%istruct 'foreign-object-domain index name recognize class-of classp
    1974               instance-class-wrapper class-own-wrapper slots-vector))
     2013              instance-class-wrapper class-own-wrapper slots-vector
     2014              class-ordinal set-class-ordinal))
    19752015 
    19762016  (let* ((n-foreign-object-domains 0)
     
    19842024                                           instance-class-wrapper
    19852025                                           class-own-wrapper
    1986                                            slots-vector)
     2026                                           slots-vector
     2027                                           class-ordinal
     2028                                           set-class-ordinal)
    19872029      (with-lock-grabbed (foreign-object-domain-lock)
    19882030        (dotimes (i n-foreign-object-domains)
     
    19962038                    (foreign-object-domain-class-own-wrapper already)
    19972039                    class-own-wrapper
    1998                     (foreign-object-domain-slots-vector already) slots-vector)
     2040                    (foreign-object-domain-slots-vector already) slots-vector
     2041                    (foreign-object-domain-class-ordinal already) class-ordinal
     2042                    (foreign-object-domain-set-class-ordinal already)
     2043                    set-class-ordinal)
    19992044              (return-from register-foreign-object-domain i))))
    20002045        (let* ((i n-foreign-object-domains)
     
    20092054                                                class-own-wrapper
    20102055                                                :slots-vector
    2011                                                 slots-vector)))
     2056                                                slots-vector
     2057                                                :class-ordinal class-ordinal
     2058                                                :set-class-ordinal set-class-ordinal)))
    20122059          (incf n-foreign-object-domains)
    20132060          (if (= i (length foreign-object-domains))
     
    20252072    (defun foreign-slots-vector (p)
    20262073      (funcall (foreign-object-domain-slots-vector (svref foreign-object-domains (%macptr-domain p))) p))
     2074    (defun foreign-class-ordinal (p)
     2075      (funcall (foreign-object-domain-class-ordinal (svref foreign-object-domains (%macptr-domain p))) p))
     2076    (defun (setf foreign-class-ordinal) (new p)
     2077      (funcall (foreign-object-domain-set-class-ordinal (svref foreign-object-domains (%macptr-domain p))) p new))
    20272078    (defun classify-foreign-pointer (p)
    20282079      (do* ((i (1- n-foreign-object-domains) (1- i)))
  • trunk/source/level-1/l1-clos.lisp

    r10420 r10423  
    723723
    724724(defmethod initialize-instance :before ((class class) &key &allow-other-keys)
     725  (setf (%class-ordinal class) (%next-class-ordinal))
    725726  (setf (%class.ctype class) (make-class-ctype class)))
    726727
Note: See TracChangeset for help on using the changeset viewer.