src/compiler/policy.lisp

   1 ;;;; compiler optimization policy stuff
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!C")
  13
  14 ;;; a value for an optimization declaration
  15 (def!type policy-quality () '(integer 0 3))
  16
  17 ;;; global policy restrictions
  18 (defvar *policy-restrictions* nil)
  19
  20 (defun restrict-compiler-policy (&optional quality (min 0))
  21   #!+sb-doc
  22   "Assing a minimum value to an optimization quality. QUALITY is the name of
  23 the optimization quality to restrict, and MIN (defaulting to zero) is the
  24 minimum allowed value.
  25
  26 Returns the alist describing the current policy restrictions.
  27
  28 If QUALITY is NIL or not given, nothing is done.
  29
  30 Otherwise, if MIN is zero or not given, any existing restrictions of QUALITY
  31 are removed. If MIN is between one and three inclusive, it becomes the new
  32 minimum value for the optimization quality: any future proclamations or
  33 declarations of the quality with a value less then MIN behave as if the value
  34 was MIN instead.
  35
  36 This is intended to be used interactively, to facilitate recompiling large
  37 bodies of code with eg. a known minimum safety.
  38
  39 See also :POLICY option in WITH-COMPILATION-UNIT.
  40
  41 EXPERIMENTAL INTERFACE: Subject to change."
  42   (declare (type policy-quality min))
  43   (when quality
  44     (aver (policy-quality-name-p quality))
  45     (if (zerop min)
  46         (setf *policy-restrictions*
  47               (remove quality *policy-restrictions* :key #'car))
  48         (let ((cell (assoc quality *policy-restrictions*)))
  49           (if cell
  50               (setf (cdr cell) min)
  51               (push (cons quality min) *policy-restrictions*)))))
  52   *policy-restrictions*)
  53
  54 ;;; CMU CL used a special STRUCTURE-OBJECT type POLICY to represent
  55 ;;; the state of optimization policy at any point in compilation. This
  56 ;;; was a natural choice, but in SBCL it became a little troublesome
  57 ;;; because of stupid technicalities involving the cold initialization
  58 ;;; of structure LAYOUTs and structure accessors, so now we just use
  59 ;;; alists instead.
  60 (def!type policy () 'list)
  61
  62 (defstruct policy-dependent-quality
  63   name
  64   expression
  65   getter
  66   values-documentation)
  67
  68 ;;; names of recognized optimization policy qualities
  69 (defvar *policy-qualities*) ; (initialized at cold init)
  70 (defvar *policy-dependent-qualities* nil) ; alist of POLICY-DEPENDENT-QUALITYs
  71
  72 ;;; Is X the name of an optimization policy quality?
  73 (defun policy-quality-name-p (x)
  74   (or (memq x *policy-qualities*)
  75       (assq x *policy-dependent-qualities*)))
  76
  77 ;;; Is it deprecated?
  78 (defun policy-quality-deprecation-warning (quality)
  79   (case quality
  80     ((stack-allocate-dynamic-extent stack-allocate-vector stack-allocate-value-cells)
  81      (deprecation-warning :late "1.0.19.7" quality '*stack-allocate-dynamic-extent*
  82                           :runtime-error nil)
  83      t)
  84     ((merge-tail-calls)
  85      (deprecation-warning :early "1.0.53.74" quality nil :runtime-error nil)
  86      t)
  87     (otherwise
  88      nil)))
  89
  90 ;;; *POLICY* holds the current global compiler policy information, as
  91 ;;; an alist mapping from optimization quality name to quality value.
  92 ;;; Inside the scope of declarations, new entries are added at the
  93 ;;; head of the alist.
  94 (declaim (type policy *policy*))
  95 (defvar *policy*)          ; initialized in cold init
  96
  97 (defun sort-policy (policy)
  98   ;; We occasionally want to compare policies using EQL, hence we
  99   ;; canonize the order.
 100   (sort policy #'string< :key #'car))
 101
 102 ;;; This is to be called early in cold init to set things up, and may
 103 ;;; also be called again later in cold init in order to reset default
 104 ;;; optimization policy back to default values after toplevel PROCLAIM
 105 ;;; OPTIMIZE forms have messed with it.
 106 (defun !policy-cold-init-or-resanify ()
 107   (setf *policy-qualities*
 108         '(;; ANSI standard qualities
 109           compilation-speed
 110           debug
 111           safety
 112           space
 113           speed
 114           ;; SBCL extensions
 115           ;;
 116           ;; FIXME: INHIBIT-WARNINGS is a misleading name for this.
 117           ;; Perhaps BREVITY would be better. But the ideal name would
 118           ;; have connotations of suppressing not warnings but only
 119           ;; optimization-related notes, which is already mostly the
 120           ;; behavior, and should probably become the exact behavior.
 121           ;; Perhaps INHIBIT-NOTES?
 122           inhibit-warnings))
 123   (setf *policy*
 124         (sort-policy (mapcar (lambda (name)
 125                                ;; CMU CL didn't use 1 as the default for
 126                                ;; everything, but since ANSI says 1 is the ordinary
 127                                ;; value, we do.
 128                                (cons name 1))
 129                              *policy-qualities*)))
 130   (setf *policy-restrictions* nil)
 131   ;; not actually POLICY, but very similar
 132   (setf *handled-conditions* nil
 133         *disabled-package-locks* nil))
 134
 135 ;;; On the cross-compilation host, we initialize immediately (not
 136 ;;; waiting for "cold init", since cold init doesn't exist on
 137 ;;; cross-compilation host).
 138 #+sb-xc-host (!policy-cold-init-or-resanify)
 139
 140 ;;; Look up a named optimization quality in POLICY. This is only
 141 ;;; called by compiler code for known-valid QUALITY-NAMEs, e.g. SPEED;
 142 ;;; it's an error if it's called for a quality which isn't defined.
 143 (defun policy-quality (policy quality-name)
 144   (aver (policy-quality-name-p quality-name))
 145   (%policy-quality policy quality-name))
 146
 147 (defun %policy-quality (policy quality-name)
 148   (let* ((acons (assoc quality-name policy))
 149          (min (or (cdr (assoc quality-name *policy-restrictions*)) 0))
 150          (result (or (cdr acons) 1)))
 151     (max result min)))
 152
 153 ;;; syntactic sugar for querying optimization policy qualities
 154 ;;;
 155 ;;; Evaluate EXPR in terms of the optimization policy associated with
 156 ;;; THING. EXPR is a form which accesses optimization qualities by
 157 ;;; referring to them by name, e.g. (> SPEED SPACE).
 158 (defmacro policy (thing expr)
 159   (let* ((n-policy (gensym "N-POLICY-"))
 160          (binds (mapcar (lambda (name)
 161                           `(,name (policy-quality ,n-policy ',name)))
 162                         *policy-qualities*))
 163          (dependent-binds
 164           (loop for (name . info) in *policy-dependent-qualities*
 165                collect `(,name (let ((,name (policy-quality ,n-policy ',name)))
 166                                  (if (= ,name 1)
 167                                      ,(policy-dependent-quality-expression info)
 168                                      ,name))))))
 169     `(let* ((,n-policy (%coerce-to-policy ,thing)))
 170        (declare (ignorable ,n-policy))
 171        (symbol-macrolet (,@binds
 172                          ,@dependent-binds)
 173          ,expr))))
 174
 175 ;;; Dependent qualities
 176 (defmacro define-optimization-quality
 177     (name expression &optional values-documentation documentation)
 178   (declare (ignorable documentation))
 179   `(eval-when (:compile-toplevel :load-toplevel :execute)
 180      (let ((acons (assoc ',name *policy-dependent-qualities*))
 181            (item (make-policy-dependent-quality
 182                   :name ',name
 183                   :expression ',expression
 184                   :getter (lambda (policy) (policy policy ,expression))
 185                   :values-documentation ',values-documentation)))
 186        (if acons
 187            (setf (cdr acons) item)
 188            (setf *policy-dependent-qualities*
 189                  (nconc *policy-dependent-qualities* (list `(,',name . ,item))))))
 190      #-sb-xc-host
 191      ,@(when documentation `((setf (fdocumentation ',name 'optimize) ,documentation)))
 192      ',name))