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