X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fpolicy.lisp;h=37ba0a72c10367dfa93e9f715dc0a1739702f107;hb=49e8403800426f37a54d9b87353a31af36e7af40;hp=d0beebeea68cfea3e7ad092f81adbe0e612c8306;hpb=b6aed043108ac99142b124306a346d18a99d21ef;p=sbcl.git

diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp
index d0beebe..37ba0a7 100644
--- a/src/compiler/policy.lisp
+++ b/src/compiler/policy.lisp
@@ -37,7 +37,7 @@ This is intended to be used interactively, to facilitate recompiling large
 bodies of code with eg. a known minimum safety.
 
 EXPERIMENTAL INTERFACE: Subject to change."
-  (declare (policy-quality min))
+  (declare (type policy-quality min))
   (when quality
     (aver (policy-quality-name-p quality))
     (if (zerop min)
@@ -72,6 +72,16 @@ EXPERIMENTAL INTERFACE: Subject to change."
   (or (memq x *policy-qualities*)
       (assq x *policy-dependent-qualities*)))
 
+;;; Is it deprecated?
+(defun policy-quality-deprecation-warning (quality spec)
+  (when (member quality '(stack-allocate-dynamic-extent stack-allocate-vector
+                          stack-allocate-value-cells))
+    (make-instance 'simple-reference-warning
+                   :format-control "~@<Ignoring deprecated optimization quality ~S in:~_ ~S~:>"
+                   :format-arguments (list quality spec)
+                   :references (list '(:sbcl :variable *stack-allocate-dynamic-extent*)
+                                     '(:sbcl :node "Dynamic-extent allocation")))))
+
 ;;; *POLICY* holds the current global compiler policy information, as
 ;;; an alist mapping from optimization quality name to quality value.
 ;;; Inside the scope of declarations, new entries are added at the
@@ -79,6 +89,11 @@ EXPERIMENTAL INTERFACE: Subject to change."
 (declaim (type policy *policy*))
 (defvar *policy*)          ; initialized in cold init
 
+(defun sort-policy (policy)
+  ;; We occasionally want to compare policies using EQL, hence we
+  ;; canonize the order.
+  (sort policy #'string< :key #'car))
+
 ;;; This is to be called early in cold init to set things up, and may
 ;;; also be called again later in cold init in order to reset default
 ;;; optimization policy back to default values after toplevel PROCLAIM
@@ -101,12 +116,12 @@ EXPERIMENTAL INTERFACE: Subject to change."
           ;; Perhaps INHIBIT-NOTES?
           inhibit-warnings))
   (setf *policy*
-        (mapcar (lambda (name)
-                  ;; CMU CL didn't use 1 as the default for
-                  ;; everything, but since ANSI says 1 is the ordinary
-                  ;; value, we do.
-                  (cons name 1))
-                *policy-qualities*))
+        (sort-policy (mapcar (lambda (name)
+                               ;; CMU CL didn't use 1 as the default for
+                               ;; everything, but since ANSI says 1 is the ordinary
+                               ;; value, we do.
+                               (cons name 1))
+                             *policy-qualities*)))
   (setf *policy-restrictions* nil)
   ;; not actually POLICY, but very similar
   (setf *handled-conditions* nil
@@ -154,16 +169,19 @@ EXPERIMENTAL INTERFACE: Subject to change."
 
 ;;; Dependent qualities
 (defmacro define-optimization-quality
-    (name expression &optional documentation)
+    (name expression &optional values-documentation documentation)
+  (declare (ignorable documentation))
   `(eval-when (:compile-toplevel :load-toplevel :execute)
      (let ((acons (assoc ',name *policy-dependent-qualities*))
            (item (make-policy-dependent-quality
                   :name ',name
                   :expression ',expression
                   :getter (lambda (policy) (policy policy ,expression))
-                  :values-documentation ',documentation)))
+                  :values-documentation ',values-documentation)))
        (if acons
            (setf (cdr acons) item)
            (setf *policy-dependent-qualities*
                  (nconc *policy-dependent-qualities* (list `(,',name . ,item))))))
+     #-sb-xc-host
+     ,@(when documentation `((setf (fdocumentation ',name 'optimize) ,documentation)))
      ',name))