[Openmcl-cvs-notifications] r10616 - /trunk/source/compiler/optimizers.lisp

[gb at clozure.com]

Author: gb
Date: Fri Sep  5 05:27:30 2008
New Revision: 10616

Log:
In OPTIMIZE-TYPEP of a type-specifier that's a class name, don't
expand into STD-INSTANCE-CLASS-CELL-TYPEP unless we're sure that
the class isnt a subtype of FUNCALLABLE-STANDARD-OBJECT (see
ticket:329), as well as checking the FOREIGN-STANDARD-OBJECT case.
We can't be sure of that unless the class exists (outside of
the lexical environment.)

Modified:
    trunk/source/compiler/optimizers.lisp

Modified: trunk/source/compiler/optimizers.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/optimizers.lisp (original)
+++ trunk/source/compiler/optimizers.lisp Fri Sep  5 05:27:30 2008
@@ -1546,11 +1546,21 @@
                                ((structure-class-p type env)
                                 `(structure-typep ,thing ',(find-class-cel=
l type t)))
                                ((find-class type nil env)
+                                ;; If we know for sure that the class
+                                ;; is one whose instances are all
+                                ;; STANDARD-INSTANCEs (not funcallable,
+                                ;; not foreign), we can use
+                                ;; STD-INSTANCE-CLASS-CELL-TYPEP, which
+                                ;; can be a little faster then the more
+                                ;; general CLASS-CELL-TYPEP.  We can
+                                ;; only be sure of that if the class
+                                ;; exists (as a non-COMPILE-TIME-CLASS)
                                 (let* ((class (find-class type nil nil))
                                        (fname =

-                                        (if (or (null class)
-                                                (and (subtypep class 'stan=
dard-object)
-                                                     (not (subtypep class =
'foreign-standard-object))))
+                                        (if (and class
+                                                 (subtypep class 'standard=
-object)
+                                                 (not (subtypep class 'for=
eign-standard-object))
+                                                 (not (subtypep class 'fun=
callable-standard-object)))
                                           'std-instance-class-cell-typep
                                           'class-cell-typep)))
                                   `(,fname ,thing (load-time-value (find-c=
lass-cell ',type t)))))