0.7.8.7:
[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 () '(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 policy qualities
26 (defvar *policy-qualities*) ; (initialized at cold init)
27
28 ;;; Is X the name of an optimization policy quality?
29 (defun policy-quality-name-p (x)
30   (memq x *policy-qualities*))
31
32 ;;; *POLICY* holds the current global compiler policy information, as
33 ;;; an alist mapping from optimization quality name to quality value.
34 ;;; Inside the scope of declarations, new entries are added at the
35 ;;; head of the alist.
36 (declaim (type policy *policy*))
37 (defvar *policy*)          ; initialized in cold init
38
39 ;;; This is to be called early in cold init to set things up, and may
40 ;;; also be called again later in cold init in order to reset default
41 ;;; optimization policy back to default values after toplevel PROCLAIM
42 ;;; OPTIMIZE forms have messed with it.
43 (defun !policy-cold-init-or-resanify ()
44   (setf *policy-qualities*
45         '(;; ANSI standard qualities
46           compilation-speed
47           debug
48           safety
49           space
50           speed
51           ;; SBCL extensions
52           ;;
53           ;; FIXME: INHIBIT-WARNINGS is a misleading name for this.
54           ;; Perhaps BREVITY would be better. But the ideal name would
55           ;; have connotations of suppressing not warnings but only
56           ;; optimization-related notes, which is already mostly the
57           ;; behavior, and should probably become the exact behavior.
58           ;; Perhaps INHIBIT-NOTES?
59           inhibit-warnings))
60   (setf *policy*
61         (mapcar (lambda (name)
62                   ;; CMU CL didn't use 1 as the default for everything,
63                   ;; but since ANSI says 1 is the ordinary value, we do.
64                   (cons name 1))
65                 *policy-qualities*)))
66 ;;; On the cross-compilation host, we initialize immediately (not
67 ;;; waiting for "cold init", since cold init doesn't exist on
68 ;;; cross-compilation host).
69 #+sb-xc-host (!policy-cold-init-or-resanify)
70
71 ;;; Look up a named optimization quality in POLICY. This is only
72 ;;; called by compiler code for known-valid QUALITY-NAMEs, e.g. SPEED;
73 ;;; it's an error if it's called for a quality which isn't defined.
74 ;;;
75 ;;; FIXME: After this is debugged, it should get a DEFKNOWN.
76 #+nil (declaim (ftype (function (policy symbol) policy-quality)))
77 (defun policy-quality (policy quality-name)
78   (let ((acons (assoc quality-name policy)))
79     (unless acons
80       (error "Argh! no such optimization quality ~S in~%  ~S"
81              quality-name policy))
82     (let ((result (cdr acons)))
83       (unless (typep result '(rational 0 3))
84         (error "Argh! bogus optimization quality ~S" acons))
85       result)))
86
87 ;;; Return a list of symbols naming the optimization qualities which
88 ;;; appear in EXPR.
89 ;;;
90 ;;; FIXME: Doing this is slightly flaky (since we can't do it right
91 ;;; without all the headaches of true code walking), and it shouldn't
92 ;;; be necessary with modern Python anyway, as long as POLICY-QUALITY
93 ;;; is properly DEFKNOWNed to have no side effects so that it can be
94 ;;; optimized away if unused. So this should probably go away.
95 (defun policy-qualities-used-by (expr)
96   (let ((result nil))
97     (labels ((recurse (x)
98                (if (listp x)
99                    (map nil #'recurse x)
100                    (when (policy-quality-name-p x)
101                      (pushnew x result)))))
102       (recurse expr)
103       result)))
104
105 ;;; syntactic sugar for querying optimization policy qualities
106 ;;;
107 ;;; Evaluate EXPR in terms of the optimization policy associated with
108 ;;; THING. EXPR is a form which accesses optimization qualities by
109 ;;; referring to them by name, e.g. (> SPEED SPACE).
110 (defmacro policy (thing expr)
111   (let* ((n-policy (gensym "N-POLICY-"))
112          (used-qualities (policy-qualities-used-by expr))
113          (binds (mapcar (lambda (name)
114                           `(,name (policy-quality ,n-policy ',name)))
115                         used-qualities)))
116     `(let* ((,n-policy (%coerce-to-policy ,thing))
117             ,@binds)
118        ,expr)))