Fix deadlocks in GC on Windows.

[sbcl.git] / src / compiler / proclaim.lisp

diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp
index acaa660..755467a 100644 (file)
--- a/src/compiler/proclaim.lisp
+++ b/src/compiler/proclaim.lisp
@@ -45,11 +45,10 @@
               (destructuring-bind (quality raw-value) q-and-v-or-just-q
                 (values quality raw-value)))
         (cond ((not (policy-quality-name-p quality))
-               (let ((deprecation-warning (policy-quality-deprecation-warning quality spec)))
-                 (if deprecation-warning
-                     (compiler-warn deprecation-warning)
-                     (compiler-warn "~@<Ignoring unknown optimization quality ~S in:~_ ~S~:>"
-                                    quality spec))))
+               (or (policy-quality-deprecation-warning quality)
+                   (compiler-warn
+                    "~@<Ignoring unknown optimization quality ~S in:~_ ~S~:>"
+                    quality spec)))
               ((not (typep raw-value 'policy-quality))
                (compiler-warn "~@<Ignoring bad optimization value ~S in:~_ ~S~:>"
                               raw-value spec))
@@ -212,10 +211,10 @@
                    (when (type/= type old-type)
                      ;; FIXME: changing to TYPE-PROCLAMATION-MISMATCH
                      ;; broke late-proclaim.lisp.
-                     (style-warn "The new TYPE proclamation~%  ~S~@
-                                  for ~S does not match the old TYPE~@
-                                  proclamation ~S"
-                                 type name old-type))))
+                     (style-warn
+                      "~@<new TYPE proclamation for ~S~@:_  ~S~@:_~
+                        does not match the old TYPE proclamation:~@:_  ~S~@:>"
+                      name (type-specifier type) (type-specifier old-type)))))
                (setf (info :variable :type name) type)
                (setf (info :variable :where-from name) :declared)))
            (push raw-form *queued-proclaims*)))
@@ -226,31 +225,36 @@
                (error "not a function type: ~S" (first args)))
              (dolist (name (rest args))
                (with-single-package-locked-error
-                   (:symbol name "globally declaring the ftype of ~A"))
-               (when (eq (info :function :where-from name) :declared)
-                 (let ((old-type (info :function :type name)))
-                   (when (type/= ctype old-type)
-                     ;; FIXME: changing to FTYPE-PROCLAMATION-MISMATCH
-                     ;; broke late-proclaim.lisp.
-                     (style-warn
-                      "new FTYPE proclamation~@
-                       ~S~@
-                       for ~S does not match old FTYPE proclamation~@
-                       ~S"
-                      ctype name old-type))))
-
-               ;; Now references to this function shouldn't be warned
-               ;; about as undefined, since even if we haven't seen a
-               ;; definition yet, we know one is planned.
-               ;;
-               ;; Other consequences of we-know-you're-a-function-now
-               ;; are appropriate too, e.g. any MACRO-FUNCTION goes away.
-               (proclaim-as-fun-name name)
-               (note-name-defined name :function)
+                   (:symbol name "globally declaring the ftype of ~A")
+                 (when (eq (info :function :where-from name) :declared)
+                   (let ((old-type (info :function :type name)))
+                     (when (type/= ctype old-type)
+                       ;; FIXME: changing to FTYPE-PROCLAMATION-MISMATCH
+                       ;; broke late-proclaim.lisp.
+                       (if (info :function :info name)
+                           ;; Allow for tightening of known function types
+                           (unless (csubtypep ctype old-type)
+                             (cerror "Continue"
+                                     "~@<new FTYPE proclamation for known function ~S~@:_  ~S~@:_~
+                                      does not match its old FTYPE:~@:_  ~S~@:>"
+                                     name (type-specifier ctype) (type-specifier old-type)))
+                           (#+sb-xc-host warn
+                            #-sb-xc-host style-warn
+                            "~@<new FTYPE proclamation for ~S~@:_  ~S~@:_~
+                             does not match the old FTYPE proclamation:~@:_  ~S~@:>"
+                            name (type-specifier ctype) (type-specifier old-type))))))
+                 ;; Now references to this function shouldn't be warned
+                 ;; about as undefined, since even if we haven't seen a
+                 ;; definition yet, we know one is planned.
+                 ;;
+                 ;; Other consequences of we-know-you're-a-function-now
+                 ;; are appropriate too, e.g. any MACRO-FUNCTION goes away.
+                 (proclaim-as-fun-name name)
+                 (note-name-defined name :function)
 
-               ;; the actual type declaration
-               (setf (info :function :type name) ctype
-                     (info :function :where-from name) :declared)))
+                 ;; the actual type declaration
+                 (setf (info :function :type name) ctype
+                       (info :function :where-from name) :declared))))
            (push raw-form *queued-proclaims*)))
       (freeze-type
        (dolist (type args)