Fix deadlocks in GC on Windows.

[sbcl.git] / src / compiler / generic / primtype.lisp

diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp
index e3e59b2..ea2e4b6 100644 (file)
--- a/src/compiler/generic/primtype.lisp
+++ b/src/compiler/generic/primtype.lisp
@@ -64,7 +64,7 @@
     #!-#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
     (:or signed-byte-32 fixnum unsigned-byte-31 positive-fixnum))
   (!def-primitive-type-alias untagged-num
-    (:or . #.(print (union (cdr '#1#) (cdr '#2#))))))
+    (:or . #.(sort (copy-list (union (cdr '#1#) (cdr '#2#))) #'string<))))
 
 ;;; other primitive immediate types
 (/show0 "primtype.lisp 68")
@@ -95,7 +95,16 @@
 (/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-DOUBLE-FLOAT")
 (!def-primitive-type complex-double-float (complex-double-reg descriptor-reg)
   :type (complex double-float))
-
+#!+sb-simd-pack
+(progn
+  (/show0 "about to !DEF-PRIMITIVE-TYPE SIMD-PACK")
+  (!def-primitive-type simd-pack-single (single-sse-reg descriptor-reg)
+    :type (simd-pack single-float))
+  (!def-primitive-type simd-pack-double (double-sse-reg descriptor-reg)
+    :type (simd-pack double-float))
+  (!def-primitive-type simd-pack-int (int-sse-reg descriptor-reg)
+   :type (simd-pack integer))
+  (!def-primitive-type-alias simd-pack (:or simd-pack-single simd-pack-double simd-pack-int)))
 
 ;;; primitive other-pointer array types
 (/show0 "primtype.lisp 96")
@@ -123,10 +132,11 @@
 
 ;;; Return the most restrictive primitive type that contains OBJECT.
 (/show0 "primtype.lisp 147")
-(!def-vm-support-routine primitive-type-of (object)
+(defun primitive-type-of (object)
   (let ((type (ctype-of object)))
     (cond ((not (member-type-p type)) (primitive-type type))
-          ((equal (member-type-members type) '(nil))
+          ((and (eql 1 (member-type-size type))
+                (equal (member-type-members type) '(nil)))
            (primitive-type-or-lose 'list))
           (t
            *backend-t-primitive-type*))))
@@ -141,7 +151,8 @@
 ;;; We need an aux function because we need to use both
 ;;; !DEF-VM-SUPPORT-ROUTINE and DEFUN-CACHED.
 (/show0 "primtype.lisp 188")
-(!def-vm-support-routine primitive-type (type)
+(defun primitive-type (type)
+  (sb!kernel::maybe-reparse-specifier! type)
   (primitive-type-aux type))
 (/show0 "primtype.lisp 191")
 (defun-cached (primitive-type-aux
@@ -341,21 +352,27 @@
                  ;; Punt.
                  (t (return (any))))))))
         (member-type
-         (let* ((members (member-type-members type))
-                (res (primitive-type-of (first members))))
-           (dolist (mem (rest members) (values res nil))
-             (let ((ptype (primitive-type-of mem)))
-               (unless (eq ptype res)
-                 (let ((new-ptype (or (maybe-numeric-type-union res ptype)
-                                      (maybe-numeric-type-union ptype res))))
-                   (if new-ptype
-                       (setq res new-ptype)
-                       (return (any)))))))))
+         (let (res)
+           (block nil
+             (mapc-member-type-members
+              (lambda (member)
+                (let ((ptype (primitive-type-of member)))
+                  (if res
+                      (unless (eq ptype res)
+                        (let ((new-ptype (or (maybe-numeric-type-union res ptype)
+                                             (maybe-numeric-type-union ptype res))))
+                          (if new-ptype
+                              (setq res new-ptype)
+                              (return (any)))))
+                      (setf res ptype))))
+              type)
+             res)))
         (named-type
          (ecase (named-type-name type)
            ((t *) (values *backend-t-primitive-type* t))
            ((instance) (exactly instance))
            ((funcallable-instance) (part-of function))
+           ((extended-sequence) (any))
            ((nil) (any))))
         (character-set-type
          (let ((pairs (character-set-type-pairs type)))
@@ -364,8 +381,21 @@
                     (= (cdar pairs) (1- sb!xc:char-code-limit)))
                (exactly character)
                (part-of character))))
+        #!+sb-simd-pack
+        (simd-pack-type
+         (let ((eltypes (simd-pack-type-element-type type)))
+           (cond ((member 'integer eltypes)
+                  (exactly simd-pack-int))
+                 ((member 'single-float eltypes)
+                  (exactly simd-pack-single))
+                 ((member 'double-float eltypes)
+                  (exactly simd-pack-double)))))
         (built-in-classoid
          (case (classoid-name type)
+           #!+sb-simd-pack
+           ;; Can't tell what specific type; assume integers.
+           (simd-pack
+            (exactly simd-pack-int))
            ((complex function system-area-pointer weak-pointer)
             (values (primitive-type-or-lose (classoid-name type)) t))
            (cons-type