(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
+ "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
-;;; became a little unwieldy, especially because of cold init issues
-;;; for structures and structure accessors, so in SBCL we use an alist
-;;; instead.
+;;; was a natural choice, but in SBCL it became a little troublesome
+;;; because of stupid technicalities involving the cold initialization
+;;; of structure LAYOUTs and structure accessors, so now we just use
+;;; alists instead.
(def!type policy () 'list)
-;;; names of recognized optimization qualities which don't have
-;;; special defaulting behavior
-(defvar *policy-basic-qualities*) ; (initialized at cold init)
-
-;;; FIXME: I'd like to get rid of DECLAIM OPTIMIZE-INTERFACE in favor
-;;; of e.g. (DECLAIM (OPTIMIZE (INTERFACE-SPEED 2) (INTERFACE-SAFETY 3))).
-#|
-;;; a list of conses (DEFAULTING-QUALITY . DEFAULT-QUALITY) of qualities
-;;; which default to other qualities when undefined, e.g. interface
-;;; speed defaulting to basic speed
-(defvar *policy-defaulting-qualities*)
-|#
-
-(defun optimization-quality-p (name)
- (or (member name *policy-basic-qualities*)
- ;; FIXME: Uncomment this when OPTIMIZE-INTERFACE goes away.
- #|(member name *policy-defaulting-qualities* :key #'car)|#))
-
-;;; *DEFAULT-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.
-;;;
-;;; *DEFAULT-INTERFACE-POLICY* holds any values specified by an
-;;; OPTIMIZE-INTERFACE declaration.
-(declaim (type policy *default-policy* *default-interface-policy*))
-(defvar *default-policy*) ; initialized in cold init
-(defvar *default-interface-policy*) ; initialized in cold init
+(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)
+ (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
+
+(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
;;; OPTIMIZE forms have messed with it.
(defun !policy-cold-init-or-resanify ()
- (setf *policy-basic-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))
- (setf *policy-defaulting-qualities*
- '((interface-speed . speed)
- (interface-safety . safety)))
- (setf *default-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-basic-qualities*))
- (setf *default-interface-policy*
- *default-policy*))
+ (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))
+ (setf *policy*
+ (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).
#+sb-xc-host (!policy-cold-init-or-resanify)
-;;; Is X the name of an optimization quality?
-(defun policy-quality-name-p (x)
- (memq x *policy-basic-qualities*))
-
;;; 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.
-(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
;;;
-;;; Evaluate EXPR in terms of the current optimization policy for
-;;; NODE, or if NODE is NIL, in terms of the current policy as defined
-;;; by *DEFAULT-POLICY* and *CURRENT-POLICY*. (Using NODE=NIL is only
-;;; well-defined during IR1 conversion.)
-;;;
-;;; EXPR is a form which accesses the policy values by referring to
-;;; them by name, e.g. (> SPEED SPACE).
-(defmacro policy (node expr)
- (let* ((n-policy (gensym))
- (used-qualities (policy-qualities-used-by expr))
- (binds (mapcar (lambda (name)
- `(,name (policy-quality ,n-policy ',name)))
- used-qualities)))
- (/show "in compile-time POLICY" expr binds)
- `(let* ((,n-policy (lexenv-policy ,(if node
- `(node-lexenv ,node)
- '*lexenv*)))
- ,@binds)
- ;;(/show "in run-time POLICY" ,@used-qualities)
- ,expr)))
+;;; Evaluate EXPR in terms of the optimization policy associated with
+;;; THING. EXPR is a form which accesses optimization qualities by
+;;; 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*))
+ (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))
projects / sbcl.git / blobdiff