Changeset 9421


Ignore:
Timestamp:
May 9, 2008, 9:26:02 AM (11 years ago)
Author:
gb
Message:

Port the "extensible/non-dt dcode functions" stuff from the trunk.

In %CLASS-CELL-TYPEP, use the new cpl-bitmap.

Assign consecutive small integers ("ordinals") to clases; still no
support for foreign-class ordinals. For standard classes, use
instance.hash to store the ordinal.

Update a bitmap whenever the CPL is cached in the class-wrapper.

Make built-in istruct classes for package-ref, type-ref.

INSTANCE-CLASS-WRAPPER is now a non-generic function.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711-perf/ccl/level-1/l1-clos-boot.lisp

    r9365 r9421  
    10711071    dcode))
    10721072
     1073(defstatic *non-dt-dcode-functions* () "List of functions which return a dcode function for the GF which is their argument.  The dcode functions will be caled with all of the incoming arguments.")
     1074
     1075(defun non-dt-dcode-function (gf)
     1076  (dolist (f *non-dt-dcode-functions*)
     1077    (let* ((dcode (funcall f gf)))
     1078      (when dcode (return dcode)))))
     1079
    10731080(defun compute-dcode (gf &optional dt)
    10741081  (setq gf (require-type gf 'standard-generic-function))
     
    10951102              (if (or (null min-index) (< index min-index))
    10961103                (setq min-index index))))))
    1097       (let ((dcode (if 0-args?
    1098                      #'%%0-arg-dcode
    1099                      (or (if multi-method-index
    1100                            #'%%nth-arg-dcode)
    1101                          (if (null other-args?)
    1102                            (if (eql nreq 1)
    1103                              #'%%one-arg-dcode
    1104                              (if (eql nreq 2)
    1105                                #'%%1st-two-arg-dcode
    1106                                #'%%1st-arg-dcode))                           
    1107                            #'%%1st-arg-dcode)))))
     1104      (let* ((non-dt (non-dt-dcode-function gf))
     1105             (dcode (or non-dt
     1106                        (if 0-args?
     1107                          #'%%0-arg-dcode
     1108                          (or (if multi-method-index
     1109                                #'%%nth-arg-dcode)
     1110                              (if (null other-args?)
     1111                                (if (eql nreq 1)
     1112                                  #'%%one-arg-dcode
     1113                                  (if (eql nreq 2)
     1114                                    #'%%1st-two-arg-dcode
     1115                                    #'%%1st-arg-dcode))
     1116                                #'%%1st-arg-dcode))))))
    11081117        (setq multi-method-index
    11091118              (if multi-method-index
     
    11171126                                                 (function-name (%combined-method-dcode old-dcode)))
    11181127                                             (cdr (%combined-method-methods old-dcode)))))
    1119           (when (or (neq dcode (if encapsulated-dcode-cons (cdr encapsulated-dcode-cons) old-dcode))
     1128          (when (or non-dt (neq dcode (if encapsulated-dcode-cons (cdr encapsulated-dcode-cons) old-dcode))
    11201129                    (neq multi-method-index (%gf-dispatch-table-argnum dt)))
    1121             (let ((proto (or (cdr (assq dcode dcode-proto-alist)) *gf-proto*)))
     1130            (let* ((proto (if non-dt
     1131                            #'funcallable-trampoline
     1132                            (or (cdr (assq dcode dcode-proto-alist)) *gf-proto*))))
    11221133              (clear-gf-dispatch-table dt)
    11231134              (setf (%gf-dispatch-table-argnum dt) multi-method-index)
     
    11261137                  (if (not (typep old-gf 'generic-function))
    11271138                    (error "Confused"))
    1128                   ;(setf (uvref old-gf 0)(uvref proto 0))
     1139                                        ;(setf (uvref old-gf 0)(uvref proto 0))
    11291140                  (setf (cdr encapsulated-dcode-cons) dcode))
    11301141                (progn
     
    12041215(defun class-cell-typep (form class-cell)
    12051216  (locally (declare (type class-cell  class-cell))
     1217    (loop
    12061218    (let ((class (class-cell-class class-cell)))
    1207       (loop
    1208         (if class
    1209           (let* ((wrapper (if (%standard-instance-p form)
    1210                             (instance.class-wrapper form)
    1211                             (instance-class-wrapper form))))
    1212             (return
    1213               (not (null (memq class (or (%wrapper-cpl wrapper)
    1214                                          (%inited-class-cpl (%wrapper-class wrapper))))))))
    1215           (if (setq class (find-class (class-cell-name class-cell) nil))
    1216             (setf (class-cell-class class-cell) class)
    1217             (return (typep form (class-cell-name class-cell)))))))))
     1219      (if class
     1220        (let* ((ordinal (%class-ordinal class))
     1221               (wrapper (instance-class-wrapper form))
     1222               (bits (or (%wrapper-cpl-bits wrapper)
     1223                         (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper))))))
     1224          (declare (fixnum ordinal))
     1225          (return
     1226            (if bits
     1227              (locally (declare (simple-bit-vector bits)
     1228                                (optimize (speed 3) (safety 0)))
     1229                  (if (< ordinal (length bits))
     1230                    (not (eql 0 (sbit bits ordinal))))))))
     1231        (let* ((name (class-cell-name class-cell))
     1232               (new-cell (find-class-cell name nil)))
     1233          (unless
     1234              (if (and new-cell (not (eq class-cell new-cell)))
     1235                (setq class-cell new-cell class (class-cell-class class-cell))
     1236                (return (typep form name))))))))))
    12181237
    12191238
     
    13441363||#
    13451364
    1346 
     1365(defglobal *next-class-ordinal* 0)
     1366
     1367(defun %next-class-ordinal ()
     1368  (%atomic-incf-node 1 '*next-class-ordinal* target::symbol.vcell))
    13471369
    13481370;;; Initialized after built-in-class is made
     
    13521374  (%istruct 'class-ctype *class-type-class* nil class nil))
    13531375
     1376(defun foreign-class-ordinal (class)
     1377  (error "NYI: foreign-class-ordinal for ~s" class))
     1378
     1379(defun (setf foreign-class-ordinal) (new class)
     1380  (error "NYI: can't set foreign-class ordinal for ~s to ~s" class new))
     1381
     1382
     1383(defun %class-ordinal (class &optional no-error)
     1384  (if (standard-instance-p class)
     1385    (instance.hash class)
     1386    (if (typep class 'macptr)
     1387      (foreign-class-ordinal class)
     1388      (unless no-error
     1389        (error "Can't determine ordinal of ~s" class)))))
     1390
     1391(defun (setf %class-ordinal) (new class &optional no-error)
     1392  (if (standard-instance-p class)
     1393    (setf (instance.hash class) new)
     1394    (if (typep class 'macptr)
     1395      (setf (foreign-class-ordinal class) new)
     1396      (unless no-error
     1397        (error "Can't set ordinal of class ~s to ~s" class new)))))
     1398
    13541399
    13551400(defvar *t-class* (let ((class (%cons-built-in-class 't)))
    1356                     (setf (%class.cpl class) (list class))
    1357                     (setf (%class.own-wrapper class)
    1358                           (%cons-wrapper class (new-class-wrapper-hash-index)))
    1359                     (setf (%class.ctype class) (make-class-ctype class))
    1360                     (setf (find-class 't) class)
    1361                     class))
     1401                    (setf (instance.hash class) 0) ;first class ordinal
     1402                    (let* ((cpl (list class))
     1403                           (wrapper (%cons-wrapper class (new-class-wrapper-hash-index))))
     1404                      (setf (%class.cpl class) cpl
     1405                            (%wrapper-cpl wrapper) cpl
     1406                            (%wrapper-cpl-bits wrapper) #*1)
     1407                      (setf (%class.own-wrapper class) wrapper)
     1408                      (setf (%class.ctype class) (make-class-ctype class))
     1409                      (setf (find-class 't) class)
     1410                      class)))
    13621411
    13631412(defun compute-cpl (class)
     
    13971446      cpl)))
    13981447
     1448(defun make-cpl-bits (cpl)
     1449  (when cpl
     1450    (let* ((max 0))
     1451      (declare (fixnum max))
     1452      (dolist (class cpl)
     1453        (let* ((ordinal (instance.hash class)))
     1454          (declare (fixnum ordinale))
     1455          (when (> ordinal max)
     1456            (setq max ordinal))))
     1457      (let* ((bits (make-array (the fixnum (1+ max)) :element-type 'bit)))
     1458        (dolist (class cpl bits)
     1459          (let* ((ordinal (instance.hash class)))
     1460            (setf (sbit bits ordinal) 1)))))))
     1461
     1462         
    13991463(defun make-built-in-class (name &rest supers)
    14001464  (if (null supers)
     
    14091473        (dolist (sup (%class.local-supers class))
    14101474          (setf (%class.subclasses sup) (nremove class (%class.subclasses sup)))))
    1411       (setq class (%cons-built-in-class name)))
     1475      (progn
     1476        (setq class (%cons-built-in-class name))
     1477        (setf (instance.hash class) (%next-class-ordinal))))
    14121478    (dolist (sup supers)
    14131479      (setf (%class.subclasses sup) (cons class (%class.subclasses sup))))
     
    14171483      (setf (%class.cpl class) cpl)
    14181484      (setf (%class.own-wrapper class) wrapper)
    1419       (setf (%wrapper-cpl wrapper) cpl))
     1485      (setf (%wrapper-cpl wrapper) cpl
     1486            (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl)
     1487            (%wrapper-class-ordinal wrapper) (%class-ordinal class)))
    14201488    (setf (%class.ctype class)  (make-class-ctype class))
    14211489    (setf (find-class name) class)
     
    14381506                 (error "Attempt to remake standard class ~s" name)
    14391507                 (%cons-standard-class name metaclass-wrapper))))
     1508    (setf (instance.hash class) (%next-class-ordinal))
    14401509    (if (null supers)
    14411510      (setq supers (list *standard-class-class*))
     
    14591528            (%class.ctype class) (make-class-ctype class)
    14601529            (%class.slots class) nil
     1530            (%wrapper-class-ordinal wrapper) (%class-ordinal class)
     1531            (%wrapper-cpl wrapper) cpl
     1532            (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl)
    14611533            (find-class name) class
    14621534            )
     
    15371609(setf (%class.own-wrapper *standard-class-class*) *standard-class-wrapper*
    15381610      (%wrapper-class *standard-class-wrapper*) *standard-class-class*
     1611      (%wrapper-class-ordinal *standard-class-wrapper*) (%class-ordinal *standard-class-class*)
    15391612      (%wrapper-instance-slots *standard-class-wrapper*) (vector))
    15401613
     
    16091682                                                              *slot-definition-class*))
    16101683(defstatic *standard-slot-definition-class* (make-standard-class 'standard-slot-definition
    1611                                                               *slot-definition-class*))
     1684                                                                 *slot-definition-class*))
    16121685(defstatic *standard-direct-slot-definition-class* (make-class
    1613                                                  'standard-direct-slot-definition
    1614                                                  *standard-class-wrapper*
    1615                                                  (list
    1616                                                   *standard-slot-definition-class*
    1617                                                   direct-slot-definition-class)))
     1686                                                    'standard-direct-slot-definition
     1687                                                    *standard-class-wrapper*
     1688                                                    (list
     1689                                                     *standard-slot-definition-class*
     1690                                                     direct-slot-definition-class)))
    16181691
    16191692(defstatic *standard-effective-slot-definition-class* (make-class
     
    16301703
    16311704
     1705
     1706
     1707 
    16321708
    16331709(let ((*dont-find-class-optimize* t)
     
    17151791 
    17161792  (make-built-in-class 'class-cell *istruct-class*)
     1793  (make-built-in-class 'type-cell *istruct-class*)
     1794  (make-built-in-class 'package-ref *istruct-class*)
    17171795  (make-built-in-class 'complex (find-class 'number))
    17181796  (make-built-in-class 'real (find-class 'number))
     
    28082886       (setf (%wrapper-hash-index wrapper) 0
    28092887             (%wrapper-cpl wrapper) nil
     2888             (%wrapper-cpl-bits wrapper) nil
    28102889             (%wrapper-instance-slots wrapper) 0
    28112890             (%wrapper-forwarding-info wrapper) forwarding-info
     
    30993178  (let ((wrapper (standard-object-p instance)))
    31003179    (unless wrapper
    3101       (if (standard-generic-function-p instance)
    3102         (setq wrapper (generic-function-wrapper instance))
    3103         (when (typep instance 'funcallable-standard-object)
    3104           (setq wrapper (gf.instance.class-wrapper instance))))
     3180              (when (typep instance 'funcallable-standard-object)
     3181          (setq wrapper (gf.instance.class-wrapper instance)))
    31053182     
    31063183      (unless wrapper
    3107         (report-bad-arg instance '(or standard-object standard-generic-function))))
     3184        (report-bad-arg instance '(or standard-object funcallable-standard-object))))
    31083185    (when (eql 0 (%wrapper-hash-index wrapper))
    31093186      (update-obsolete-instance instance)))
     
    35033580(setf (fdefinition '%do-remove-direct-method) #'remove-direct-method)
    35043581
    3505 (defmethod instance-class-wrapper (x)
    3506   (%class.own-wrapper (class-of x)))
    3507 
    3508 (defmethod instance-class-wrapper ((instance standard-object))
    3509   (if (%standard-instance-p instance)
    3510     (instance.class-wrapper instance)
    3511     (if (typep instance 'macptr)
    3512       (foreign-instance-class-wrapper instance)
    3513       (%class.own-wrapper (class-of instance)))))
    3514 
    3515 (defmethod instance-class-wrapper ((instance standard-generic-function))
    3516   (gf.instance.class-wrapper  instance))
     3582
     3583(defun instance-class-wrapper (instance)
     3584  (cond ((%standard-instance-p instance) (instance.class-wrapper instance))
     3585        ((typep instance 'funcallable-standard-object)
     3586         (gf.instance.class-wrapper instance))
     3587        ((typep instance 'macptr) (foreign-instance-class-wrapper instance))
     3588        (t (%class.own-wrapper (class-of instance)))))
    35173589
    35183590
    35193591                                   
    35203592
    3521 (defun generic-function-wrapper (gf)
    3522   (unless (inherits-from-standard-generic-function-p (class-of gf))
    3523     (%badarg gf 'standard-generic-function))
    3524   (gf.instance.class-wrapper gf))
     3593
    35253594
    35263595(defvar *make-load-form-saving-slots-hash* (make-hash-table :test 'eq))
Note: See TracChangeset for help on using the changeset viewer.