Optimize MAKE-ARRAY on unknown element-type.

[sbcl.git] / src / code / typep.lisp

diff --git a/src/code/typep.lisp b/src/code/typep.lisp
index 36e776a..374d3bc 100644 (file)
--- a/src/code/typep.lisp
+++ b/src/code/typep.lisp
@@ -31,7 +31,7 @@
            (if (ctype-p specifier)
                specifier
                (specifier-type specifier))))
-(defun %%typep (object type)
+(defun %%typep (object type &optional (strict t))
   (declare (type ctype type))
   (etypecase type
     (named-type
@@ -39,6 +39,7 @@
        ((* t) t)
        ((instance) (%instancep object))
        ((funcallable-instance) (funcallable-instance-p object))
+       ((extended-sequence) (extended-sequence-p object))
        ((nil) nil)))
     (numeric-type
      (and (numberp object)
@@ -104,21 +105,28 @@
                              (specifier-type (array-element-type
                                               object)))))))
     (member-type
-     (if (member object (member-type-members type)) t))
+     (when (member-type-member-p object type)
+       t))
     (classoid
      #+sb-xc-host (ctypep object type)
      #-sb-xc-host (classoid-typep (layout-of object) type object))
     (union-type
-     (some (lambda (union-type-type) (%%typep object union-type-type))
+     (some (lambda (union-type-type) (%%typep object union-type-type strict))
            (union-type-types type)))
     (intersection-type
      (every (lambda (intersection-type-type)
-              (%%typep object intersection-type-type))
+              (%%typep object intersection-type-type strict))
             (intersection-type-types type)))
     (cons-type
      (and (consp object)
-          (%%typep (car object) (cons-type-car-type type))
-          (%%typep (cdr object) (cons-type-cdr-type type))))
+          (%%typep (car object) (cons-type-car-type type) strict)
+          (%%typep (cdr object) (cons-type-cdr-type type) strict)))
+    #!+sb-simd-pack
+    (simd-pack-type
+     (and (simd-pack-p object)
+          (let* ((tag (%simd-pack-tag object))
+                 (name (nth tag *simd-pack-element-types*)))
+            (not (not (member name (simd-pack-type-element-type type)))))))
     (character-set-type
      (and (characterp object)
          (let ((code (char-code object))
@@ -135,16 +143,16 @@
        (if (typep reparse 'unknown-type)
            (error "unknown type specifier: ~S"
                   (unknown-type-specifier reparse))
-           (%%typep object reparse))))
+           (%%typep object reparse strict))))
     (negation-type
-     (not (%%typep object (negation-type-type type))))
+     (not (%%typep object (negation-type-type type) strict)))
     (hairy-type
      ;; Now the tricky stuff.
      (let* ((hairy-spec (hairy-type-specifier type))
             (symbol (car hairy-spec)))
        (ecase symbol
          (and
-          (every (lambda (spec) (%%typep object (specifier-type spec)))
+          (every (lambda (spec) (%%typep object (specifier-type spec) strict))
                  (rest hairy-spec)))
          ;; Note: it should be safe to skip OR here, because union
          ;; types can always be represented as UNION-TYPE in general
@@ -153,7 +161,7 @@
          (not
           (unless (proper-list-of-length-p hairy-spec 2)
             (error "invalid type specifier: ~S" hairy-spec))
-          (not (%%typep object (specifier-type (cadr hairy-spec)))))
+          (not (%%typep object (specifier-type (cadr hairy-spec)) strict)))
          (satisfies
           (unless (proper-list-of-length-p hairy-spec 2)
             (error "invalid type specifier: ~S" hairy-spec))
@@ -161,8 +169,11 @@
     (alien-type-type
      (sb!alien-internals:alien-typep object (alien-type-type-alien-type type)))
     (fun-type
-     (error "Function types are not a legal argument to TYPEP:~%  ~S"
-            (type-specifier type)))))
+     (if strict
+         (error "Function types are not a legal argument to TYPEP:~%  ~S"
+                (type-specifier type))
+         (and (functionp object)
+              (csubtypep (specifier-type (sb!impl::%fun-type object)) type))))))
 
 ;;; Do a type test from a class cell, allowing forward reference and
 ;;; redefinition.
@@ -176,6 +187,14 @@
 ;;; Test whether OBJ-LAYOUT is from an instance of CLASSOID.
 (defun classoid-typep (obj-layout classoid object)
   (declare (optimize speed))
+  ;; FIXME & KLUDGE: We could like to grab the *WORLD-LOCK* here (to ensure that
+  ;; class graph doesn't change while we're doing the typep test), but in
+  ;; pratice that causes trouble -- deadlocking against the compiler
+  ;; if compiler output (or macro, or compiler-macro expansion) causes
+  ;; another thread to do stuff. Not locking is a shoddy bandaid as it is remains
+  ;; easy to trigger the same problem using a different code path -- but in practice
+  ;; locking here makes Slime unusable with :SPAWN in post *WORLD-LOCK* world. So...
+  ;; -- NS 2008-12-16
   (multiple-value-bind (obj-layout layout)
       (do ((layout (classoid-layout classoid) (classoid-layout classoid))
            (i 0 (+ i 1))
@@ -185,12 +204,8 @@
            (values obj-layout layout))
         (aver (< i 2))
         (when (layout-invalid obj-layout)
-          (if (typep (classoid-of object) 'standard-classoid)
-              (setq obj-layout (sb!pcl::check-wrapper-validity object))
-              (error "~S was called on an obsolete object (classoid ~S)."
-                     'typep
-                     (classoid-proper-name (layout-classoid obj-layout)))))
-        (ensure-classoid-valid classoid layout))
+          (setq obj-layout (update-object-layout-or-invalid object layout)))
+        (%ensure-classoid-valid classoid layout "typep"))
     (let ((obj-inherits (layout-inherits obj-layout)))
       (or (eq obj-layout layout)
           (dotimes (i (length obj-inherits) nil)