;;; 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.
+
+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
;;; 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
;;; 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
;;; 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*))
+ (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))
+ *disabled-package-locks* nil))
;;; On the cross-compilation host, we initialize immediately (not
;;; waiting for "cold init", since cold init doesn't exist on
;;; 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
;;;
;;; referring to them by name, e.g. (> SPEED SPACE).
(defmacro policy (thing expr)
(let* ((n-policy (gensym "N-POLICY-"))
- (binds (mapcar (lambda (name)
- `(,name (policy-quality ,n-policy ',name)))
- *policy-qualities*))
+ (binds (mapcar (lambda (name)
+ `(,name (policy-quality ,n-policy ',name)))
+ *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))