X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fpolicy.lisp;h=cadc959b370566020b5e3cd485f248bd9e105c96;hb=eda83f00e869193cb69826be5fa1086b95d12ff7;hp=fae8e1972c635fb35250f3c1ce2807c73bfc52ba;hpb=d604a358d8e5eb5587989e0a4f1d31dbe6ac5ffe;p=sbcl.git diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp index fae8e19..cadc959 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 + "Assign 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 ;;; @@ -102,29 +162,31 @@ *policy-qualities*)) (dependent-binds (loop for (name . info) in *policy-dependent-qualities* - collect `(,name (policy-quality ,n-policy ',name)) - collect `(,name (if (= ,name 1) - ,(policy-dependent-quality-expression info) - ,name))))) - `(let* ((,n-policy (%coerce-to-policy ,thing)) - ,@binds - ,@dependent-binds) - (declare (ignorable ,@*policy-qualities* - ,@(mapcar #'car *policy-dependent-qualities*))) - ,expr))) + collect `(,name (let ((,name (policy-quality ,n-policy ',name))) + (if (= ,name 1) + ,(policy-dependent-quality-expression info) + ,name)))))) + `(let* ((,n-policy (%coerce-to-policy ,thing))) + (declare (ignorable ,n-policy)) + (symbol-macrolet (,@binds + ,@dependent-binds) + ,expr)))) ;;; 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))