X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fpolicy.lisp;h=c6b31aad20e4e41b42ef5f7e0ed5c708496446f4;hb=0b3f5cc5fa9e6b121d232960ccd964d2eb15f695;hp=0e7a4ebe08e2e58c75d64427a5e5aa1d4e40c4e5;hpb=30479182014bc1e02f54d330643ca45605e3530d;p=sbcl.git

diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp
index 0e7a4eb..c6b31aa 100644
--- a/src/compiler/policy.lisp
+++ b/src/compiler/policy.lisp
@@ -14,6 +14,43 @@
 ;;; a value for an optimization declaration
 (def!type policy-quality () '(integer 0 3))
 
+;;; global policy restrictions
+(defvar *policy-restrictions* nil)
+
+(defun restrict-compiler-policy (&optional quality (min 0))
+  #!+sb-doc
+  "Assing a minimum value to an optimization quality. QUALITY is the name of
+the optimization quality to restrict, and MIN (defaulting to zero) is the
+minimum allowed value.
+
+Returns the alist describing the current policy restrictions.
+
+If QUALITY is NIL or not given, nothing is done.
+
+Otherwise, if MIN is zero or not given, any existing restrictions of QUALITY
+are removed. If MIN is between one and three inclusive, it becomes the new
+minimum value for the optimization quality: any future proclamations or
+declarations of the quality with a value less then MIN behave as if the value
+was MIN instead.
+
+This is intended to be used interactively, to facilitate recompiling large
+bodies of code with eg. a known minimum safety.
+
+See also :POLICY option in WITH-COMPILATION-UNIT.
+
+EXPERIMENTAL INTERFACE: Subject to change."
+  (declare (type policy-quality min))
+  (when quality
+    (aver (policy-quality-name-p quality))
+    (if (zerop min)
+        (setf *policy-restrictions*
+              (remove quality *policy-restrictions* :key #'car))
+        (let ((cell (assoc quality *policy-restrictions*)))
+          (if cell
+              (setf (cdr cell) min)
+              (push (cons quality min) *policy-restrictions*)))))
+  *policy-restrictions*)
+
 ;;; CMU CL used a special STRUCTURE-OBJECT type POLICY to represent
 ;;; the state of optimization policy at any point in compilation. This
 ;;; was a natural choice, but in SBCL it became a little troublesome
@@ -37,6 +74,19 @@
   (or (memq x *policy-qualities*)
       (assq x *policy-dependent-qualities*)))
 
+;;; Is it deprecated?
+(defun policy-quality-deprecation-warning (quality)
+  (case quality
+    ((stack-allocate-dynamic-extent stack-allocate-vector stack-allocate-value-cells)
+     (deprecation-warning :late "1.0.19.7" quality '*stack-allocate-dynamic-extent*
+                          :runtime-error nil)
+     t)
+    ((merge-tail-calls)
+     (deprecation-warning :early "1.0.53.74" quality nil :runtime-error nil)
+     t)
+    (otherwise
+     nil)))
+
 ;;; *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
@@ -44,6 +94,11 @@
 (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
@@ -66,12 +121,13 @@
           ;; 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
         *disabled-package-locks* nil))
@@ -86,9 +142,13 @@
 ;;; it's an error if it's called for a quality which isn't defined.
 (defun policy-quality (policy quality-name)
   (aver (policy-quality-name-p quality-name))
+  (%policy-quality policy quality-name))
+
+(defun %policy-quality (policy quality-name)
   (let* ((acons (assoc quality-name policy))
+         (min (or (cdr (assoc quality-name *policy-restrictions*)) 0))
          (result (or (cdr acons) 1)))
-    result))
+    (max result min)))
 
 ;;; syntactic sugar for querying optimization policy qualities
 ;;;
@@ -114,16 +174,19 @@
 
 ;;; 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))