1.0.31.13: working XREF for inlined lambda with hairy lambda-lists
[sbcl.git] / src / compiler / constantp.lisp
1 ;;;; implementation of CONSTANTP, needs both INFO and IR1-ATTRIBUTES
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 (!begin-collecting-cold-init-forms)
15
16 (defvar *special-form-constantp-funs*)
17 (declaim (type hash-table *special-form-constantp-funs*))
18 (!cold-init-forms
19   (setf *special-form-constantp-funs* (make-hash-table)))
20
21 (defvar *special-form-constant-form-value-funs*)
22 (declaim (type hash-table *special-form-constant-form-value-funs*))
23 (!cold-init-forms
24   (setf *special-form-constant-form-value-funs* (make-hash-table)))
25
26 (defvar *special-constant-variables*)
27 (!cold-init-forms
28   (setf *special-constant-variables* nil))
29
30 (defun %constantp (form environment envp)
31   (let ((form (if envp
32                   (sb!xc:macroexpand form environment)
33                   form)))
34     (typecase form
35       ;; This INFO test catches KEYWORDs as well as explicitly
36       ;; DEFCONSTANT symbols.
37       (symbol
38        (or (eq (info :variable :kind form) :constant)
39            (constant-special-variable-p form)))
40       (list
41        (or (constant-special-form-p form environment envp)
42            #-sb-xc-host
43            (values (constant-function-call-p form environment envp))))
44       (t t))))
45
46 (defun %constant-form-value (form environment envp)
47   (let ((form (if envp
48                   (sb!xc:macroexpand form environment)
49                   form)))
50     (typecase form
51       (symbol
52        ;; KLUDGE: superficially, this might look good enough: we grab
53        ;; the value from the info database, and if it isn't there (or
54        ;; is NIL, but hey) we use the host's value.  This works for
55        ;; MOST-POSITIVE-FIXNUM and friends, but still fails for
56        ;; float-related constants, where there is in fact no guarantee
57        ;; that we can represent our target value at all in the host,
58        ;; so we don't try.  We should rework all uses of floating
59        ;; point so that we never try to use a host's value, and then
60        ;; make some kind of assertion that we never attempt to take
61        ;; a host value of a constant in the CL package.
62        #+sb-xc-host (or (info :variable :xc-constant-value form)
63                         (symbol-value form))
64        #-sb-xc-host (symbol-value form))
65       (list
66        (if (special-operator-p (car form))
67            (constant-special-form-value form environment envp)
68            #-sb-xc-host
69            (constant-function-call-value form environment envp)))
70       (t
71        form))))
72
73 (defun constant-special-form-p (form environment envp)
74   (let ((fun (gethash (car form) *special-form-constantp-funs*)))
75     (when fun
76       (funcall fun form environment envp))))
77
78 (defun constant-special-form-value (form environment envp)
79   (let ((fun (gethash (car form) *special-form-constant-form-value-funs*)))
80     (if fun
81         (funcall fun form environment envp)
82         (error "Not a constant-foldable special form: ~S" form))))
83
84 (defun constant-special-variable-p (name)
85   (and (member name *special-constant-variables*) t))
86
87 ;;; FIXME: It would be nice to deal with inline functions
88 ;;; too.
89 (defun constant-function-call-p (form environment envp)
90   (let ((name (car form)))
91     (if (and (legal-fun-name-p name)
92              (eq :function (info :function :kind name))
93              (let ((info (info :function :info name)))
94                (and info (ir1-attributep (fun-info-attributes info)
95                                          foldable)))
96              (and (every (lambda (arg)
97                            (%constantp arg environment envp))
98                          (cdr form))))
99         ;; Even though the function may be marked as foldable
100         ;; the call may still signal an error -- eg: (CAR 1).
101         (handler-case
102             (values t (constant-function-call-value form environment envp))
103           (error ()
104             (values nil nil)))
105         (values nil nil))))
106
107 (defun constant-function-call-value (form environment envp)
108   (apply (fdefinition (car form))
109          (mapcar (lambda (arg)
110                    (%constant-form-value arg environment envp))
111                  (cdr form))))
112
113 #!-sb-fluid (declaim (inline sb!xc:constantp))
114 (defun sb!xc:constantp (form &optional (environment nil envp))
115   #!+sb-doc
116   "True of any FORM that has a constant value: self-evaluating objects,
117 keywords, defined constants, quote forms. Additionally the
118 constant-foldability of some function calls special forms is recognized. If
119 ENVIRONMENT is provided the FORM is first macroexpanded in it."
120   (%constantp form environment envp))
121
122 #!-sb-fluid (declaim (inline constant-form-value))
123 (defun constant-form-value (form &optional (environment nil envp))
124   #!+sb-doc
125   "Returns the value of the constant FORM in ENVIRONMENT. Behaviour
126 is undefined unless CONSTANTP has been first used to determine the
127 constantness of the FORM in ENVIRONMENT."
128   (%constant-form-value form environment envp))
129
130 (declaim (inline constant-typep))
131 (defun constant-typep (form type &optional (environment nil envp))
132   (and (%constantp form environment envp)
133        ;; FIXME: We probably should be passing the environment to
134        ;; TYPEP too, but (1) our XC version of typep AVERs that the
135        ;; environment is null (2) our real version ignores it anyhow.
136        (sb!xc:typep (%constant-form-value form environment envp) type)))
137
138 ;;;; NOTE!!!
139 ;;;;
140 ;;;; If you add new special forms, check that they do not
141 ;;;; alter the logic of existing ones: eg, currently
142 ;;;; CONSTANT-FORM-VALUE directly evaluates the last expression
143 ;;;; of a PROGN, as no assignment is allowed. If you extend
144 ;;;; analysis to assignments then other forms must take this
145 ;;;; into account.
146
147 (defmacro defconstantp (operator lambda-list &key test eval)
148   (with-unique-names (form environment envp)
149     (flet ((frob (body)
150              `(flet ((constantp* (x)
151                        (%constantp x ,environment ,envp))
152                      (constant-form-value* (x)
153                        (%constant-form-value x ,environment ,envp)))
154                 (declare (ignorable #'constantp* #'constant-form-value*))
155                 (destructuring-bind ,lambda-list (cdr ,form)
156                   ;; KLUDGE: is all we need, so we keep it simple
157                   ;; instead of general (not handling cases like &key (x y))
158                   (declare (ignorable
159                             ,@(remove-if (lambda (arg)
160                                            (member arg sb!xc:lambda-list-keywords))
161                                          lambda-list)))
162                    ,body))))
163       `(progn
164          (setf (gethash ',operator *special-form-constantp-funs*)
165                (lambda (,form ,environment ,envp)
166                  ,(frob test)))
167          (setf (gethash ',operator *special-form-constant-form-value-funs*)
168                (lambda (,form ,environment ,envp)
169                  ,(frob eval)))))))
170
171 (!cold-init-forms
172  (defconstantp quote (value)
173    :test t
174    :eval value)
175
176  (defconstantp if (test then &optional else)
177    :test
178    (and (constantp* test)
179         (constantp* (if (constant-form-value* test)
180                         then
181                         else)))
182    :eval (if (constant-form-value* test)
183              (constant-form-value* then)
184              (constant-form-value* else)))
185
186  (defconstantp progn (&body forms)
187    :test (every #'constantp* forms)
188    :eval (constant-form-value* (car (last forms))))
189
190  (defconstantp unwind-protect (protected-form &body cleanup-forms)
191    :test (every #'constantp* (cons protected-form cleanup-forms))
192    :eval (constant-form-value* protected-form))
193
194  (defconstantp the (type form)
195    :test (and (constantp* form)
196               (handler-case
197                   ;; in case the type-spec is malformed!
198                   (typep (constant-form-value* form) type)
199                 (error () nil)))
200    :eval (constant-form-value* form))
201
202  (defconstantp block (name &body forms)
203    ;; We currently fail to detect cases like
204    ;;
205    ;; (BLOCK FOO
206    ;;   ...CONSTANT-FORMS...
207    ;;   (RETURN-FROM FOO CONSTANT-VALUE)
208    ;;   ...ANYTHING...)
209    ;;
210    ;; Right now RETURN-FROM kills the constantness unequivocally.
211    :test (every #'constantp* forms)
212    :eval (constant-form-value* (car (last forms))))
213
214  (defconstantp multiple-value-prog1 (first-form &body forms)
215    :test (every #'constantp* (cons first-form forms))
216    :eval (constant-form-value* first-form))
217
218  (defconstantp progv (symbols values &body forms)
219    :test (and (constantp* symbols)
220               (constantp* values)
221               (let* ((symbol-values (constant-form-value* symbols))
222                      (*special-constant-variables*
223                       (append symbol-values *special-constant-variables*)))
224                 (progv
225                     symbol-values
226                     (constant-form-value* values)
227                   (every #'constantp* forms))))
228    :eval (progv
229              (constant-form-value* symbols)
230              (constant-form-value* values)
231            (constant-form-value* (car (last forms))))))
232
233 (!defun-from-collected-cold-init-forms !constantp-cold-init)
234