1.0.41.37: ppc: allocation fixes for threaded builds.
[sbcl.git] / 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 spec)
79   (when (member quality '(stack-allocate-dynamic-extent stack-allocate-vector
80                           stack-allocate-value-cells))
81     (make-instance 'simple-reference-warning
82                    :format-control "~@<Ignoring deprecated optimization quality ~S in:~_ ~S~:>"
83                    :format-arguments (list quality spec)
84                    :references (list '(:sbcl :variable *stack-allocate-dynamic-extent*)
85                                      '(:sbcl :node "Dynamic-extent allocation")))))
86
87 ;;; *POLICY* holds the current global compiler policy information, as
88 ;;; an alist mapping from optimization quality name to quality value.
89 ;;; Inside the scope of declarations, new entries are added at the
90 ;;; head of the alist.
91 (declaim (type policy *policy*))
92 (defvar *policy*)          ; initialized in cold init
93
94 (defun sort-policy (policy)
95   ;; We occasionally want to compare policies using EQL, hence we
96   ;; canonize the order.
97   (sort policy #'string< :key #'car))
98
99 ;;; This is to be called early in cold init to set things up, and may
100 ;;; also be called again later in cold init in order to reset default
101 ;;; optimization policy back to default values after toplevel PROCLAIM
102 ;;; OPTIMIZE forms have messed with it.
103 (defun !policy-cold-init-or-resanify ()
104   (setf *policy-qualities*
105         '(;; ANSI standard qualities
106           compilation-speed
107           debug
108           safety
109           space
110           speed
111           ;; SBCL extensions
112           ;;
113           ;; FIXME: INHIBIT-WARNINGS is a misleading name for this.
114           ;; Perhaps BREVITY would be better. But the ideal name would
115           ;; have connotations of suppressing not warnings but only
116           ;; optimization-related notes, which is already mostly the
117           ;; behavior, and should probably become the exact behavior.
118           ;; Perhaps INHIBIT-NOTES?
119           inhibit-warnings))
120   (setf *policy*
121         (sort-policy (mapcar (lambda (name)
122                                ;; CMU CL didn't use 1 as the default for
123                                ;; everything, but since ANSI says 1 is the ordinary
124                                ;; value, we do.
125                                (cons name 1))
126                              *policy-qualities*)))
127   (setf *policy-restrictions* nil)
128   ;; not actually POLICY, but very similar
129   (setf *handled-conditions* nil
130         *disabled-package-locks* nil))
131
132 ;;; On the cross-compilation host, we initialize immediately (not
133 ;;; waiting for "cold init", since cold init doesn't exist on
134 ;;; cross-compilation host).
135 #+sb-xc-host (!policy-cold-init-or-resanify)
136
137 ;;; Look up a named optimization quality in POLICY. This is only
138 ;;; called by compiler code for known-valid QUALITY-NAMEs, e.g. SPEED;
139 ;;; it's an error if it's called for a quality which isn't defined.
140 (defun policy-quality (policy quality-name)
141   (aver (policy-quality-name-p quality-name))
142   (%policy-quality policy quality-name))
143
144 (defun %policy-quality (policy quality-name)
145   (let* ((acons (assoc quality-name policy))
146          (min (or (cdr (assoc quality-name *policy-restrictions*)) 0))
147          (result (or (cdr acons) 1)))
148     (max result min)))
149
150 ;;; syntactic sugar for querying optimization policy qualities
151 ;;;
152 ;;; Evaluate EXPR in terms of the optimization policy associated with
153 ;;; THING. EXPR is a form which accesses optimization qualities by
154 ;;; referring to them by name, e.g. (> SPEED SPACE).
155 (defmacro policy (thing expr)
156   (let* ((n-policy (gensym "N-POLICY-"))
157          (binds (mapcar (lambda (name)
158                           `(,name (policy-quality ,n-policy ',name)))
159                         *policy-qualities*))
160          (dependent-binds
161           (loop for (name . info) in *policy-dependent-qualities*
162                collect `(,name (let ((,name (policy-quality ,n-policy ',name)))
163                                  (if (= ,name 1)
164                                      ,(policy-dependent-quality-expression info)
165                                      ,name))))))
166     `(let* ((,n-policy (%coerce-to-policy ,thing)))
167        (declare (ignorable ,n-policy))
168        (symbol-macrolet (,@binds
169                          ,@dependent-binds)
170          ,expr))))
171
172 ;;; Dependent qualities
173 (defmacro define-optimization-quality
174     (name expression &optional values-documentation documentation)
175   (declare (ignorable documentation))
176   `(eval-when (:compile-toplevel :load-toplevel :execute)
177      (let ((acons (assoc ',name *policy-dependent-qualities*))
178            (item (make-policy-dependent-quality
179                   :name ',name
180                   :expression ',expression
181                   :getter (lambda (policy) (policy policy ,expression))
182                   :values-documentation ',values-documentation)))
183        (if acons
184            (setf (cdr acons) item)
185            (setf *policy-dependent-qualities*
186                  (nconc *policy-dependent-qualities* (list `(,',name . ,item))))))
187      #-sb-xc-host
188      ,@(when documentation `((setf (fdocumentation ',name 'optimize) ,documentation)))
189      ',name))