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 () '(rational 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 ;;; names of recognized optimization qualities which don't have
  26 ;;; special defaulting behavior
  27 (defvar *policy-basic-qualities*) ; (initialized at cold init)
  28
  29 ;;; FIXME: I'd like to get rid of DECLAIM OPTIMIZE-INTERFACE in favor
  30 ;;; of e.g. (DECLAIM (OPTIMIZE (INTERFACE-SPEED 2) (INTERFACE-SAFETY 3))).
  31 #|
  32 ;;; a list of conses (DEFAULTING-QUALITY . DEFAULT-QUALITY) of qualities
  33 ;;; which default to other qualities when undefined, e.g. interface
  34 ;;; speed defaulting to basic speed
  35 (defvar *policy-defaulting-qualities*)
  36 |#
  37
  38 (defun optimization-quality-p (name)
  39   (or (member name *policy-basic-qualities*)
  40       ;; FIXME: Uncomment this when OPTIMIZE-INTERFACE goes away.
  41       #|(member name *policy-defaulting-qualities* :key #'car)|#))
  42
  43 ;;; *POLICY* holds the current global compiler policy information, as
  44 ;;; an alist mapping from optimization quality name to quality value.
  45 ;;; Inside the scope of declarations, new entries are added at the
  46 ;;; head of the alist.
  47 ;;;
  48 ;;; *INTERFACE-POLICY* holds global interface policy, represented the
  49 ;;; same way as in *DEFAULT-POLICY*.
  50 (declaim (type policy *policy* *interface-policy*))
  51 (defvar *policy*)          ; initialized in cold init
  52 (defvar *interface-policy*) ; initialized in cold init
  53
  54 ;;; This is to be called early in cold init to set things up, and may
  55 ;;; also be called again later in cold init in order to reset default
  56 ;;; optimization policy back to default values after toplevel PROCLAIM
  57 ;;; OPTIMIZE forms have messed with it.
  58 (defun !policy-cold-init-or-resanify ()
  59   (setf *policy-basic-qualities*
  60         '(;; ANSI standard qualities
  61           compilation-speed
  62           debug
  63           safety
  64           space
  65           speed
  66           ;; SBCL extensions
  67           ;;
  68           ;; FIXME: INHIBIT-WARNINGS is a misleading name for this.
  69           ;; Perhaps BREVITY would be better. But the ideal name would
  70           ;; have connotations of suppressing not warnings but only
  71           ;; optimization-related notes, which is already mostly the
  72           ;; behavior, and should probably become the exact behavior.
  73           ;; Perhaps INHIBIT-NOTES?
  74           inhibit-warnings))
  75   #|
  76   (setf *policy-defaulting-qualities*
  77         '((interface-speed . speed)
  78           (interface-safety . safety)))
  79   |#
  80   (setf *policy*
  81         (mapcar (lambda (name)
  82                   ;; CMU CL didn't use 1 as the default for everything,
  83                   ;; but since ANSI says 1 is the ordinary value, we do.
  84                   (cons name 1))
  85                 *policy-basic-qualities*))
  86   (setf *interface-policy*
  87         *policy*))
  88 ;;; On the cross-compilation host, we initialize immediately (not
  89 ;;; waiting for "cold init", since cold init doesn't exist on
  90 ;;; cross-compilation host).
  91 #+sb-xc-host (!policy-cold-init-or-resanify)
  92
  93 ;;; Is X the name of an optimization quality?
  94 (defun policy-quality-name-p (x)
  95   (memq x *policy-basic-qualities*))
  96
  97 ;;; Look up a named optimization quality in POLICY. This is only
  98 ;;; called by compiler code for known-valid QUALITY-NAMEs, e.g. SPEED;
  99 ;;; it's an error if it's called for a quality which isn't defined.
 100 ;;;
 101 ;;; FIXME: After this is debugged, it should get a DEFKNOWN.
 102 #+nil (declaim (ftype (function (policy symbol) policy-quality)))
 103 (defun policy-quality (policy quality-name)
 104   (let ((acons (assoc quality-name policy)))
 105     (unless acons
 106       (error "Argh! no such optimization quality ~S in~%  ~S"
 107              quality-name policy))
 108     (let ((result (cdr acons)))
 109       (unless (typep result '(rational 0 3))
 110         (error "Argh! bogus optimization quality ~S" acons))
 111       result)))
 112
 113 ;;; Return a list of symbols naming the optimization qualities which
 114 ;;; appear in EXPR.
 115 (defun policy-qualities-used-by (expr)
 116   (let ((result nil))
 117     (labels ((recurse (x)
 118                (if (listp x)
 119                    (map nil #'recurse x)
 120                    (when (policy-quality-name-p x)
 121                      (pushnew x result)))))
 122       (recurse expr)
 123       result)))
 124
 125 ;;; syntactic sugar for querying optimization policy qualities
 126 ;;;
 127 ;;; Evaluate EXPR in terms of the current optimization policy for
 128 ;;; NODE, or if NODE is NIL, in terms of the current policy as defined
 129 ;;; by *POLICY*. (Using NODE=NIL is only well-defined during
 130 ;;; IR1 conversion.)
 131 ;;;
 132 ;;; EXPR is a form which accesses the policy values by referring to
 133 ;;; them by name, e.g. (> SPEED SPACE).
 134 (defmacro policy (node expr)
 135   (let* ((n-policy (gensym))
 136          (used-qualities (policy-qualities-used-by expr))
 137          (binds (mapcar (lambda (name)
 138                           `(,name (policy-quality ,n-policy ',name)))
 139                         used-qualities)))
 140     `(let* ((,n-policy (lexenv-policy ,(if node
 141                                            `(node-lexenv ,node)
 142                                            '*lexenv*)))
 143             ,@binds)
 144        ,expr)))