Changeset 11121 for trunk/source/level-1


Ignore:
Timestamp:
Oct 17, 2008, 12:34:34 PM (11 years ago)
Author:
gz
Message:

From working-0711 branch: class/class subtypep method uses bitmaps and ordinals, for better performance

File:
1 edited

Legend:

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

    r10942 r11121  
    17511751
    17521752(setf (type-predicate 'negation-ctype) 'negation-ctype-p)
    1753 
    17541753
    17551754(define-type-method (negation :unparse) (x)
     
    34463445                                     '(args-ctype values-ctype function-ctype))))
    34473446
    3448 (defun valuec-ctype-p (x) (istruct-typep x 'values-ctype))
    3449 
    34503447(setf (type-predicate 'args-ctype) 'args-ctype-p
    34513448      (type-predicate 'function-ctype) 'function-ctype-p
     
    34653462         (class2 (if (class-ctype-p type2) (class-ctype-class type2))))
    34663463    (if (and class1 class2)
    3467       (if (memq class2 (class-direct-superclasses class1))
    3468         (values t t)
    3469         (if (or (class-has-a-forward-referenced-superclass-p class1)
    3470                 (typep class1 'compile-time-class))
    3471           (values nil nil)
    3472           (let ((supers (%inited-class-cpl class1)))
    3473             (if (memq class2 supers)
    3474               (values t t)
    3475               (values nil t)))))
     3464      (let* ((ordinal2 (%class-ordinal class2))
     3465             (wrapper1 (%class.own-wrapper class1))
     3466             (bits1 (if wrapper1 (%wrapper-cpl-bits wrapper1))))
     3467        (if bits1
     3468          (locally (declare (simple-bit-vector bits1)
     3469                            (optimize (speed 3) (safety 0)))
     3470            (values (if (< ordinal2 (length bits1))
     3471                      (not (eql 0 (sbit bits1 ordinal2))))
     3472                    t))
     3473          (if (%standard-instance-p class1)
     3474            (if (memq class2 (%class.local-supers class1))
     3475              (values t t)
     3476              (if (eq (%class-of-instance class1)
     3477                      *forward-referenced-class-class*)
     3478                (values nil nil)
     3479                ;; %INITED-CLASS-CPL will return NIL if class1 can't
     3480                ;; be finalized; in that case, we don't know the answer.
     3481                (let ((supers (%inited-class-cpl class1)))
     3482                  (if (memq class2 supers)
     3483                    (values t t)
     3484                    (values nil (not (null supers)))))))
     3485            (values nil t))))
    34763486      (values nil t))))
    34773487
Note: See TracChangeset for help on using the changeset viewer.