Changeset 9429


Ignore:
Timestamp:
May 9, 2008, 10:13:30 AM (11 years ago)
Author:
gb
Message:

Support methods for TYPE-CELLs. CELL-CSUBTYPEP-2 expects its second
arg to be a TYPE-CELL which caches a CTYPE.

Class/class subtypep method uses bitmaps and ordinals. Faster, if
we get to it.

File:
1 edited

Legend:

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

    r9351 r9429  
    178178  `(specifier-type ',(type-specifier c)))
    179179
     180(defmethod make-load-form ((cell type-cell) &optional env)
     181  (declare (ignore env))
     182  `(register-type-cell `,(type-cell-type-specifier cell)))
     183
     184(defmethod print-object ((cell type-cell) stream)
     185  (print-unreadable-object (cell stream :type t :identity t)
     186    (format stream "for ~s" (type-cell-type-specifier cell))))
    180187
    181188(defun make-key-info (&key name type)
     
    11081115                             type1 type2
    11091116                             :complex-arg1 :complex-subtypep-arg1))))
     1117
     1118;;; Type1 is a type-epecifier; type2 is a TYPE-CELL which may cache
     1119;;; a mapping between a type-specifier and a CTYPE.
     1120(defun cell-csubtypep-2 (type-specifier type-cell)
     1121  (let* ((type1 (specifier-type type-specifier))
     1122         (type2 (or (type-cell-ctype type-cell)
     1123                    (let* ((ctype (specifier-type
     1124                                   (type-cell-type-specifier type-cell))))
     1125                      (when (cacheable-ctype-p ctype)
     1126                        (setf (type-cell-ctype type-cell) ctype))
     1127                      ctype))))
     1128    (cond ((or (eq type1 type2)
     1129               (eq type1 *empty-type*)
     1130               (eq type2 *wild-type*))
     1131           (values t t))
     1132          (t
     1133           (invoke-type-method :simple-subtypep :complex-subtypep-arg2
     1134                               type1 type2
     1135                               :complex-arg1 :complex-subtypep-arg1)))))
     1136                             
     1137
     1138
    11101139;;; Type=  --  Interface
    11111140;;;
     
    34363465         (class2 (if (class-ctype-p type2) (class-ctype-class type2))))
    34373466    (if (and class1 class2)
    3438       (if (memq class2 (class-direct-superclasses class1))
    3439         (values t t)
    3440         ;; %INITED-CLASS-CPL will return NIL if class1 can't
    3441         ;; be finalized; in that case, we don't know the answer.
    3442         (let ((supers (%inited-class-cpl class1)))
    3443           (if (memq class2 supers)
     3467      (let* ((ordinal2 (%class-ordinal class2))
     3468             (bits1 (%wrapper-cpl-bits (%class.own-wrapper class1))))
     3469        (if bits1
     3470          (locally (declare (simple-bit-vector bits1)
     3471                            (optimize (speed 3) (safety 0)))
     3472            (values (if (< ordinal2 (length bits1))
     3473                      (not (eql 0 (sbit bits1 ordinal2))))
     3474                    t))
     3475          (if (memq class2 (class-direct-superclasses class1))
    34443476            (values t t)
    3445             (values nil (not (null supers))))))
     3477            ;; %INITED-CLASS-CPL will return NIL if class1 can't
     3478            ;; be finalized; in that case, we don't know the answer.
     3479            (let ((supers (%inited-class-cpl class1)))
     3480              (if (memq class2 supers)
     3481                (values t t)
     3482                (values nil (not (null supers))))))))
    34463483      (values nil t))))
    34473484
Note: See TracChangeset for help on using the changeset viewer.