Changeset 9708


Ignore:
Timestamp:
Jun 9, 2008, 1:21:02 AM (11 years ago)
Author:
gb
Message:

OPTIMIZE-TYPEP: look in *istruct-cells* early, to avoid FIND-CLASS
at compile-time in more cases.

File:
1 edited

Legend:

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

    r9573 r9708  
    15151515        (if (and predicate (symbolp predicate))
    15161516          `(,predicate ,thing)
    1517           (or (optimize-ctypep thing ctype)
    1518               (cond ((symbolp type)
    1519                      (cond ((%deftype-expander type)
    1520                             ;; recurse here, rather than returning the
    1521                             ;; partially-expanded form mostly since it doesn't
    1522                             ;; seem to further optimize the result otherwise
    1523                             (let ((expanded-type (type-expand type)))
    1524                               (or (optimize-typep thing expanded-type env)
    1525                                   ;; at least do the first expansion
    1526                                   `(typep ,thing ',expanded-type))))
    1527                            ((structure-class-p type env)
    1528                             `(structure-typep ,thing ',(find-class-cell type t)))
    1529                            ((find-class type nil env)
    1530                             (let* ((class (find-class type nil)))
    1531                               (if (and class
    1532                                        (subtypep class *istruct-class*)
    1533                                        (null (class-direct-subclasses class)))
    1534                                 `(istruct-typep ,thing ',type)
    1535                                 `(class-cell-typep ,thing (load-time-value (find-class-cell ',type t))))))
    1536                            ((info-type-builtin type) ; bootstrap troubles here?
     1517          (let* ((pair (assq type *istruct-cells*))
     1518                 (class (and pair (%wrapper-class (istruct-cell-info pair)))))
     1519            (if (and class (not (%class-direct-subclasses class)))
     1520              `(istruct-typep ,thing ',type)             
     1521              (or (optimize-ctypep thing ctype)
     1522                  (cond ((symbolp type)
     1523                         (cond ((%deftype-expander type)
     1524                                ;; recurse here, rather than returning the
     1525                                ;; partially-expanded form mostly since it doesn't
     1526                                ;; seem to further optimize the result otherwise
     1527                                (let ((expanded-type (type-expand type)))
     1528                                  (or (optimize-typep thing expanded-type env)
     1529                                      ;; at least do the first expansion
     1530                                      `(typep ,thing ',expanded-type))))
     1531                               ((structure-class-p type env)
     1532                                `(structure-typep ,thing ',(find-class-cell type t)))
     1533                               ((find-class type nil env)
     1534                                `(class-cell-typep ,thing (load-time-value (find-class-cell ',type t))))
     1535                               ((info-type-builtin type) ; bootstrap troubles here?
     1536                                `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
     1537                               (t nil)))
     1538                        ((consp type)
     1539                         (cond
     1540                           ((info-type-builtin type) ; byte types
    15371541                            `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
    1538                            (t nil)))
    1539                     ((consp type)
    1540                      (cond
    1541                        ((info-type-builtin type) ; byte types
    1542                         `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
    1543                        (t
    1544                         (case (%car type)
    1545                           (satisfies `(funcall ',(cadr type) ,thing))
    1546                           (eql `(eql ,thing ',(cadr type)))
    1547                           (member `(not (null (member ,thing ',(%cdr type)))))
    1548                           (not `(not (typep ,thing ',(cadr type))))
    1549                           ((or and)
    1550                            (let ((thing-sym (gensym)))
    1551                              `(let ((,thing-sym ,thing))
    1552                                (,(%car type)
    1553                                 ,@(mapcar #'(lambda (type-spec)
    1554                                               (or (optimize-typep thing-sym type-spec env)
    1555                                                   `(typep ,thing-sym ',type-spec)))
    1556                                           (%cdr type))))))
    1557                           ((signed-byte unsigned-byte integer mod) ; more byte types
    1558                            `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
    1559                           (t nil)))))
    1560                     (t nil))))))))
     1542                           (t
     1543                            (case (%car type)
     1544                              (satisfies `(funcall ',(cadr type) ,thing))
     1545                              (eql `(eql ,thing ',(cadr type)))
     1546                              (member `(not (null (member ,thing ',(%cdr type)))))
     1547                              (not `(not (typep ,thing ',(cadr type))))
     1548                              ((or and)
     1549                               (let ((thing-sym (gensym)))
     1550                                 `(let ((,thing-sym ,thing))
     1551                                   (,(%car type)
     1552                                    ,@(mapcar #'(lambda (type-spec)
     1553                                                  (or (optimize-typep thing-sym type-spec env)
     1554                                                      `(typep ,thing-sym ',type-spec)))
     1555                                              (%cdr type))))))
     1556                              ((signed-byte unsigned-byte integer mod) ; more byte types
     1557                               `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
     1558                              (t nil)))))
     1559                        (t nil))))))))))
    15611560
    15621561(define-compiler-macro typep  (&whole call &environment env thing type &optional e)
     
    17231722
    17241723(define-compiler-macro slot-boundp (&whole whole instance slot-name-form)
    1725   (declare (ignore env))
    17261724  (let* ((name (and (quoted-form-p slot-name-form)
    17271725                    (typep (cadr slot-name-form) 'symbol)
     
    19761974               `(let ((,stream-var ,stream))
    19771975                  (if (or (null ,stream-var) (stringp ,stream-var))
    1978                     (format-to-string ,stream-var ,string ,obj ,@args)
     1976                    (format-to-string ,stream-var ,string ,@args)
    19791977                    (let ((,stream-var
    19801978                           (if (eq ,stream-var t) *standard-output* ,stream-var)))
Note: See TracChangeset for help on using the changeset viewer.