1 ;;;; compiler optimization policy stuff
3 ;;;; This software is part of the SBCL system. See the README file for
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.
14 ;;; a value for an optimization declaration
15 (def!type policy-quality
() '(integer 0 3))
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
23 (def!type policy
() 'list
)
25 (defstruct policy-dependent-quality
31 ;;; names of recognized optimization policy qualities
32 (defvar *policy-qualities
*) ; (initialized at cold init)
33 (defvar *policy-dependent-qualities
* nil
) ; alist of POLICY-DEPENDENT-QUALITYs
35 ;;; Is X the name of an optimization policy quality?
36 (defun policy-quality-name-p (x)
37 (or (memq x
*policy-qualities
*)
38 (assq x
*policy-dependent-qualities
*)))
40 ;;; *POLICY* holds the current global compiler policy information, as
41 ;;; an alist mapping from optimization quality name to quality value.
42 ;;; Inside the scope of declarations, new entries are added at the
43 ;;; head of the alist.
44 (declaim (type policy
*policy
*))
45 (defvar *policy
*) ; initialized in cold init
47 ;;; This is to be called early in cold init to set things up, and may
48 ;;; also be called again later in cold init in order to reset default
49 ;;; optimization policy back to default values after toplevel PROCLAIM
50 ;;; OPTIMIZE forms have messed with it.
51 (defun !policy-cold-init-or-resanify
()
52 (setf *policy-qualities
*
53 '(;; ANSI standard qualities
61 ;; FIXME: INHIBIT-WARNINGS is a misleading name for this.
62 ;; Perhaps BREVITY would be better. But the ideal name would
63 ;; have connotations of suppressing not warnings but only
64 ;; optimization-related notes, which is already mostly the
65 ;; behavior, and should probably become the exact behavior.
66 ;; Perhaps INHIBIT-NOTES?
69 (mapcar (lambda (name)
70 ;; CMU CL didn't use 1 as the default for
71 ;; everything, but since ANSI says 1 is the ordinary
75 ;; not actually POLICY, but very similar
76 (setf *handled-conditions
* nil
77 *disabled-package-locks
* nil
))
79 ;;; On the cross-compilation host, we initialize immediately (not
80 ;;; waiting for "cold init", since cold init doesn't exist on
81 ;;; cross-compilation host).
82 #+sb-xc-host
(!policy-cold-init-or-resanify
)
84 ;;; Look up a named optimization quality in POLICY. This is only
85 ;;; called by compiler code for known-valid QUALITY-NAMEs, e.g. SPEED;
86 ;;; it's an error if it's called for a quality which isn't defined.
87 (defun policy-quality (policy quality-name
)
88 (aver (policy-quality-name-p quality-name
))
89 (let* ((acons (assoc quality-name policy
))
90 (result (or (cdr acons
) 1)))
93 ;;; syntactic sugar for querying optimization policy qualities
95 ;;; Evaluate EXPR in terms of the optimization policy associated with
96 ;;; THING. EXPR is a form which accesses optimization qualities by
97 ;;; referring to them by name, e.g. (> SPEED SPACE).
98 (defmacro policy
(thing expr
)
99 (let* ((n-policy (gensym "N-POLICY-"))
100 (binds (mapcar (lambda (name)
101 `(,name
(policy-quality ,n-policy
',name
)))
104 (loop for
(name . info
) in
*policy-dependent-qualities
*
105 collect
`(,name
(policy-quality ,n-policy
',name
))
106 collect
`(,name
(if (= ,name
1)
107 ,(policy-dependent-quality-expression info
)
109 `(let* ((,n-policy
(%coerce-to-policy
,thing
))
112 (declare (ignorable ,@*policy-qualities
*
113 ,@(mapcar #'car
*policy-dependent-qualities
*)))
116 ;;; Dependent qualities
117 (defmacro define-optimization-quality
118 (name expression
&optional documentation
)
119 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
120 (let ((acons (assoc ',name
*policy-dependent-qualities
*))
121 (item (make-policy-dependent-quality
123 :expression
',expression
124 :getter
(lambda (policy) (policy policy
,expression
))
125 :values-documentation
',documentation
)))
127 (setf (cdr acons
) item
)
128 (setf *policy-dependent-qualities
*
129 (nconc *policy-dependent-qualities
* (list `(,',name .
,item
))))))