Changeset 9938


Ignore:
Timestamp:
Jul 10, 2008, 8:50:11 AM (11 years ago)
Author:
gb
Message:

In OPTIMIZE-TYPEP: check for istruct types a little earlier, avoid
FIND-CLASS issues.

INSTANCE-CLASS-WRAPPER: if not standard-instance, call
NON-STANDARD-INSTANCE-CLASS-WRAPPER.

READ-CHAR (with &optional args) -> READ-CHAR-INTERNAL (with fixed args).

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/optimizers.lisp

    r9724 r9938  
    15121512        (if (and predicate (symbolp predicate))
    15131513          `(,predicate ,thing)
    1514           (or (optimize-ctypep thing ctype)
    1515               (cond ((symbolp type)
    1516                      (cond ((%deftype-expander type)
    1517                             ;; recurse here, rather than returning the
    1518                             ;; partially-expanded form mostly since it doesn't
    1519                             ;; seem to further optimize the result otherwise
    1520                             (let ((expanded-type (type-expand type)))
    1521                               (or (optimize-typep thing expanded-type env)
    1522                                   ;; at least do the first expansion
    1523                                   `(typep ,thing ',expanded-type))))
    1524                            ((structure-class-p type env)
    1525                             `(structure-typep ,thing ',(find-class-cell type t)))
    1526                            ((find-class type nil env)
    1527                             (let* ((class (find-class type nil)))
    1528                               (if (and class
    1529                                        (subtypep class *istruct-class*)
    1530                                        (null (class-direct-subclasses class)))
    1531                                 `(istruct-typep ,thing ',type)
    1532                                 `(class-cell-typep ,thing (load-time-value (find-class-cell ',type t))))))
    1533                            ((info-type-builtin type) ; bootstrap troubles here?
     1514          (let* ((pair (assq type *istruct-cells*))
     1515                 (class (and pair (%wrapper-class (istruct-cell-info pair)))))
     1516            (if (and class (not (%class-direct-subclasses class)))
     1517              `(istruct-typep ,thing ',type)             
     1518              (or (optimize-ctypep thing ctype)
     1519                  (cond ((symbolp type)
     1520                         (cond ((%deftype-expander type)
     1521                                ;; recurse here, rather than returning the
     1522                                ;; partially-expanded form mostly since it doesn't
     1523                                ;; seem to further optimize the result otherwise
     1524                                (let ((expanded-type (type-expand type)))
     1525                                  (or (optimize-typep thing expanded-type env)
     1526                                      ;; at least do the first expansion
     1527                                      `(typep ,thing ',expanded-type))))
     1528                               ((structure-class-p type env)
     1529                                `(structure-typep ,thing ',(find-class-cell type t)))
     1530                               ((find-class type nil env)
     1531                                (let* ((class (find-class type nil nil))
     1532                                       (fname
     1533                                        (if (or (null class)
     1534                                                (and (subtypep class 'standard-object)
     1535                                                     (not (subtypep class 'foreign-standard-object))))
     1536                                          'std-instance-class-cell-typep
     1537                                          'class-cell-typep)))
     1538                                  `(,fname ,thing (load-time-value (find-class-cell ',type t)))))
     1539                               ((info-type-builtin type) ; bootstrap troubles here?
     1540                                `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
     1541                               (t nil)))
     1542                        ((consp type)
     1543                         (cond
     1544                           ((info-type-builtin type) ; byte types
    15341545                            `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
    1535                            (t nil)))
    1536                     ((consp type)
    1537                      (cond
    1538                        ((info-type-builtin type) ; byte types
    1539                         `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
    1540                        (t
    1541                         (case (%car type)
    1542                           (satisfies `(funcall ',(cadr type) ,thing))
    1543                           (eql `(eql ,thing ',(cadr type)))
    1544                           (member `(not (null (member ,thing ',(%cdr type)))))
    1545                           (not `(not (typep ,thing ',(cadr type))))
    1546                           ((or and)
    1547                            (let ((thing-sym (gensym)))
    1548                              `(let ((,thing-sym ,thing))
    1549                                (,(%car type)
    1550                                 ,@(mapcar #'(lambda (type-spec)
    1551                                               (or (optimize-typep thing-sym type-spec env)
    1552                                                   `(typep ,thing-sym ',type-spec)))
    1553                                           (%cdr type))))))
    1554                           ((signed-byte unsigned-byte integer mod) ; more byte types
    1555                            `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
    1556                           (t nil)))))
    1557                     (t nil))))))))
     1546                           (t
     1547                            (case (%car type)
     1548                              (satisfies `(funcall ',(cadr type) ,thing))
     1549                              (eql `(eql ,thing ',(cadr type)))
     1550                              (member `(not (null (member ,thing ',(%cdr type)))))
     1551                              (not `(not (typep ,thing ',(cadr type))))
     1552                              ((or and)
     1553                               (let ((thing-sym (gensym)))
     1554                                 `(let ((,thing-sym ,thing))
     1555                                   (,(%car type)
     1556                                    ,@(mapcar #'(lambda (type-spec)
     1557                                                  (or (optimize-typep thing-sym type-spec env)
     1558                                                      `(typep ,thing-sym ',type-spec)))
     1559                                              (%cdr type))))))
     1560                              ((signed-byte unsigned-byte integer mod) ; more byte types
     1561                               `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
     1562                              (t nil)))))
     1563                        (t nil))))))))))
    15581564
    15591565(define-compiler-macro typep  (&whole call &environment env thing type &optional e)
     
    22152221               ,(nx-lookup-target-uvector-subtag :instance))
    22162222        (instance.class-wrapper ,itemp)
    2217         (funcall 'instance-class-wrapper ,itemp)))))
     2223        (non-standard-instance-class-wrapper ,itemp)))))
    22182224
    22192225;; Instance must be a standard-instance.
     
    22852291                                        '(or symbol string)))
    22862292    `(load-time-value (register-package-ref ,(string arg)))))
     2293
    22872294
    22882295
     
    23762383  (or (if (typep name 'keyword) (lookup-character-encoding name))
    23772384      w))
    2378    
     2385
     2386(define-compiler-macro read-char (&optional stream (eof-error-p t) eof-value recursive-p)
     2387  `(read-char-internal ,stream ,eof-error-p (values ,eof-value ,recursive-p)))
     2388
    23792389(provide "OPTIMIZERS")
Note: See TracChangeset for help on using the changeset viewer.