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