X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fpolicy.lisp;h=c6b31aad20e4e41b42ef5f7e0ed5c708496446f4;hb=74cf7a4d01664fbf72a662ba093ad67ca243b524;hp=e780e4bc9af9e5cf2ca4ec553d82bce02927e54f;hpb=34dd23563d2f5cf05c72b971da0d0b065a09bf2a;p=sbcl.git diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp index e780e4b..c6b31aa 100644 --- a/src/compiler/policy.lisp +++ b/src/compiler/policy.lisp @@ -12,7 +12,44 @@ (in-package "SB!C") ;;; a value for an optimization declaration -(def!type policy-quality () '(rational 0 3)) +(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 @@ -22,19 +59,45 @@ ;;; alists instead. (def!type policy () 'list) +(defstruct policy-dependent-quality + name + expression + getter + values-documentation) + ;;; names of recognized optimization policy qualities (defvar *policy-qualities*) ; (initialized at cold init) +(defvar *policy-dependent-qualities* nil) ; alist of POLICY-DEPENDENT-QUALITYs ;;; Is X the name of an optimization policy quality? (defun policy-quality-name-p (x) - (memq x *policy-qualities*)) + (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 ;;; head of the alist. (declaim (type policy *policy*)) -(defvar *policy*) ; initialized in cold init +(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 @@ -42,27 +105,33 @@ ;;; OPTIMIZE forms have messed with it. (defun !policy-cold-init-or-resanify () (setf *policy-qualities* - '(;; ANSI standard qualities - compilation-speed - debug - safety - space - speed - ;; SBCL extensions - ;; - ;; FIXME: INHIBIT-WARNINGS is a misleading name for this. - ;; Perhaps BREVITY would be better. But the ideal name would - ;; have connotations of suppressing not warnings but only - ;; optimization-related notes, which is already mostly the - ;; behavior, and should probably become the exact behavior. - ;; Perhaps INHIBIT-NOTES? - inhibit-warnings)) + '(;; ANSI standard qualities + compilation-speed + debug + safety + space + speed + ;; SBCL extensions + ;; + ;; FIXME: INHIBIT-WARNINGS is a misleading name for this. + ;; Perhaps BREVITY would be better. But the ideal name would + ;; have connotations of suppressing not warnings but only + ;; optimization-related notes, which is already mostly the + ;; behavior, and should probably become the exact behavior. + ;; 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)) + ;;; On the cross-compilation host, we initialize immediately (not ;;; waiting for "cold init", since cold init doesn't exist on ;;; cross-compilation host). @@ -71,36 +140,15 @@ ;;; Look up a named optimization quality in POLICY. This is only ;;; called by compiler code for known-valid QUALITY-NAMEs, e.g. SPEED; ;;; it's an error if it's called for a quality which isn't defined. -;;; -;;; FIXME: After this is debugged, it should get a DEFKNOWN. -#+nil (declaim (ftype (function (policy symbol) policy-quality))) (defun policy-quality (policy quality-name) - (let ((acons (assoc quality-name policy))) - (unless acons - (error "Argh! no such optimization quality ~S in~% ~S" - quality-name policy)) - (let ((result (cdr acons))) - (unless (typep result '(rational 0 3)) - (error "Argh! bogus optimization quality ~S" acons)) - result))) - -;;; Return a list of symbols naming the optimization qualities which -;;; appear in EXPR. -;;; -;;; FIXME: Doing this is slightly flaky (since we can't do it right -;;; without all the headaches of true code walking), and it shouldn't -;;; be necessary with modern Python anyway, as long as POLICY-QUALITY -;;; is properly DEFKNOWNed to have no side effects so that it can be -;;; optimized away if unused. So this should probably go away. -(defun policy-qualities-used-by (expr) - (let ((result nil)) - (labels ((recurse (x) - (if (listp x) - (map nil #'recurse x) - (when (policy-quality-name-p x) - (pushnew x result))))) - (recurse expr) - result))) + (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))) + (max result min))) ;;; syntactic sugar for querying optimization policy qualities ;;; @@ -109,10 +157,36 @@ ;;; referring to them by name, e.g. (> SPEED SPACE). (defmacro policy (thing expr) (let* ((n-policy (gensym "N-POLICY-")) - (used-qualities (policy-qualities-used-by expr)) - (binds (mapcar (lambda (name) - `(,name (policy-quality ,n-policy ',name))) - used-qualities))) - `(let* ((,n-policy (%coerce-to-policy ,thing)) - ,@binds) - ,expr))) + (binds (mapcar (lambda (name) + `(,name (policy-quality ,n-policy ',name))) + *policy-qualities*)) + (dependent-binds + (loop for (name . info) in *policy-dependent-qualities* + 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 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 ',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))