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 ;;; CMU CL used a special STRUCTURE-OBJECT type POLICY to represent
  18 ;;; the state of optimization policy at any point in compilation. This
  19 ;;; was a natural choice, but in SBCL it became a little troublesome
  20 ;;; because of stupid technicalities involving the cold initialization
  21 ;;; of structure LAYOUTs and structure accessors, so now we just use
  22 ;;; alists instead.
  23 (def!type policy () 'list)
  24
  25 ;;; FIXME: the original implementation of this was protected by
  26 ;;;
  27 ;;; (eval-when (#-sb-xc-host :compile-toplevel :load-toplevel :execute)
  28 ;;;
  29 ;;; but I don't know why.  This seems to work, but I don't understand
  30 ;;; why the original wasn't this in the first place.  -- CSR,
  31 ;;; 2003-05-04
  32 (defstruct policy-dependent-quality
  33   name
  34   expression
  35   getter
  36   values-documentation)
  37
  38 ;;; names of recognized optimization policy qualities
  39 (defvar *policy-qualities*) ; (initialized at cold init)
  40 (eval-when (:compile-toplevel :load-toplevel :execute)
  41   (defvar *policy-dependent-qualities* nil)) ; alist of POLICY-DEPENDENT-QUALITYs
  42
  43 ;;; Is X the name of an optimization policy quality?
  44 (defun policy-quality-name-p (x)
  45   (or (memq x *policy-qualities*)
  46       (assq x *policy-dependent-qualities*)))
  47
  48 ;;; *POLICY* holds the current global compiler policy information, as
  49 ;;; an alist mapping from optimization quality name to quality value.
  50 ;;; Inside the scope of declarations, new entries are added at the
  51 ;;; head of the alist.
  52 (declaim (type policy *policy*))
  53 (defvar *policy*)          ; initialized in cold init
  54
  55 ;;; This is to be called early in cold init to set things up, and may
  56 ;;; also be called again later in cold init in order to reset default
  57 ;;; optimization policy back to default values after toplevel PROCLAIM
  58 ;;; OPTIMIZE forms have messed with it.
  59 (defun !policy-cold-init-or-resanify ()
  60   (setf *policy-qualities*
  61         '(;; ANSI standard qualities
  62           compilation-speed
  63           debug
  64           safety
  65           space
  66           speed
  67           ;; SBCL extensions
  68           ;;
  69           ;; FIXME: INHIBIT-WARNINGS is a misleading name for this.
  70           ;; Perhaps BREVITY would be better. But the ideal name would
  71           ;; have connotations of suppressing not warnings but only
  72           ;; optimization-related notes, which is already mostly the
  73           ;; behavior, and should probably become the exact behavior.
  74           ;; Perhaps INHIBIT-NOTES?
  75           inhibit-warnings))
  76   (setf *policy*
  77         (mapcar (lambda (name)
  78                   ;; CMU CL didn't use 1 as the default for everything,
  79                   ;; but since ANSI says 1 is the ordinary value, we do.
  80                   (cons name 1))
  81                 *policy-qualities*)))
  82 ;;; On the cross-compilation host, we initialize immediately (not
  83 ;;; waiting for "cold init", since cold init doesn't exist on
  84 ;;; cross-compilation host).
  85 #+sb-xc-host (!policy-cold-init-or-resanify)
  86
  87 ;;; Look up a named optimization quality in POLICY. This is only
  88 ;;; called by compiler code for known-valid QUALITY-NAMEs, e.g. SPEED;
  89 ;;; it's an error if it's called for a quality which isn't defined.
  90 (defun policy-quality (policy quality-name)
  91   (let* ((acons (assoc quality-name policy))
  92          (result (or (cdr acons) 1)))
  93     result))
  94
  95 ;;; syntactic sugar for querying optimization policy qualities
  96 ;;;
  97 ;;; Evaluate EXPR in terms of the optimization policy associated with
  98 ;;; THING. EXPR is a form which accesses optimization qualities by
  99 ;;; referring to them by name, e.g. (> SPEED SPACE).
 100 (defmacro policy (thing expr)
 101   (let* ((n-policy (gensym "N-POLICY-"))
 102          (binds (mapcar (lambda (name)
 103                           `(,name (policy-quality ,n-policy ',name)))
 104                         *policy-qualities*))
 105          (dependent-binds
 106           (loop for (name . info) in *policy-dependent-qualities*
 107                collect `(,name (policy-quality ,n-policy ',name))
 108                collect `(,name (if (= ,name 1)
 109                                    ,(policy-dependent-quality-expression info)
 110                                    ,name)))))
 111     `(let* ((,n-policy (%coerce-to-policy ,thing))
 112             ,@binds
 113             ,@dependent-binds)
 114        (declare (ignorable ,@*policy-qualities*
 115                            ,@(mapcar #'car *policy-dependent-qualities*)))
 116        ,expr)))
 117
 118 ;;; Dependent qualities
 119 (defmacro define-optimization-quality
 120     (name expression &optional documentation)
 121   `(eval-when (:compile-toplevel :load-toplevel :execute)
 122      (let ((acons (assoc ',name *policy-dependent-qualities*))
 123            (item (make-policy-dependent-quality
 124                   :name ',name
 125                   :expression ',expression
 126                   :getter (lambda (policy) (policy policy ,expression))
 127                   :values-documentation ',documentation)))
 128        (if acons
 129            (setf (cdr acons) item)
 130            (push `(,',name . ,item) *policy-dependent-qualities*)))
 131      ',name))