1 ;;;; This file contains stuff for maintaining a database of special
2 ;;;; information about functions known to the compiler. This includes
3 ;;;; semantic information such as side effects and type inference
4 ;;;; functions as well as transforms and IR2 translators.
6 ;;;; This software is part of the SBCL system. See the README file for
9 ;;;; This software is derived from the CMU CL system, which was
10 ;;;; written at Carnegie Mellon University and released into the
11 ;;;; public domain. The software is in the public domain and is
12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
13 ;;;; files for more information.
17 (/show0
"knownfun.lisp 17")
19 ;;;; interfaces to defining macros
22 (defstruct (transform (:copier nil
))
23 ;; the function type which enables this transform.
25 ;; (Note that declaring this :TYPE FUN-TYPE probably wouldn't
26 ;; work because some function types, like (SPECIFIER-TYPE 'FUNCTION0
27 ;; itself, are represented as BUILT-IN-TYPE, and at least as of
28 ;; sbcl-0.pre7.54 or so, that's inconsistent with being a
30 (type (missing-arg) :type ctype
)
31 ;; the transformation function. Takes the COMBINATION node and
32 ;; returns a lambda expression, or throws out.
33 (function (missing-arg) :type function
)
34 ;; string used in efficiency notes
35 (note (missing-arg) :type string
)
36 ;; T if we should emit a failure note even if SPEED=INHIBIT-WARNINGS.
37 (important nil
:type
(member nil
:slightly t
)))
39 (defprinter (transform) type note important
)
41 ;;; Grab the FUN-INFO and enter the function, replacing any old
42 ;;; one with the same type and note.
43 (declaim (ftype (function (t list function
&optional
(or string null
)
44 (member nil
:slightly t
))
47 (defun %deftransform
(name type fun
&optional note important
)
48 (let* ((ctype (specifier-type type
))
49 (note (or note
"optimize"))
50 (info (fun-info-or-lose name
))
51 (old (find-if (lambda (x)
52 (and (type= (transform-type x
) ctype
)
53 (string-equal (transform-note x
) note
)
54 (eq (transform-important x
) important
)))
55 (fun-info-transforms info
))))
57 (style-warn 'redefinition-with-deftransform
59 (setf (transform-function old
) fun
60 (transform-note old
) note
))
62 (push (make-transform :type ctype
:function fun
:note note
64 (fun-info-transforms info
))))
67 ;;; Make a FUN-INFO structure with the specified type, attributes
69 (declaim (ftype (function (list list attributes t
&key
70 (:derive-type
(or function null
))
71 (:optimizer
(or function null
))
72 (:destroyed-constant-args
(or function null
))
73 (:result-arg
(or index null
))
74 (:overwrite-fndb-silently boolean
)
75 (:foldable-call-check
(or function null
))
76 (:callable-check
(or function null
)))
79 (defun %defknown
(names type attributes location
80 &key derive-type optimizer destroyed-constant-args result-arg
81 overwrite-fndb-silently
84 (let ((ctype (specifier-type type
))
85 (info (make-fun-info :attributes attributes
86 :derive-type derive-type
88 :destroyed-constant-args destroyed-constant-args
89 :result-arg result-arg
90 :foldable-call-check foldable-call-check
91 :callable-check callable-check
)))
93 (unless overwrite-fndb-silently
94 (let ((old-fun-info (info :function
:info name
)))
96 ;; This is handled as an error because it's generally a bad
97 ;; thing to blow away all the old optimization stuff. It's
98 ;; also a potential source of sneaky bugs:
101 ;; DEFKNOWN FOO ; possibly hidden inside some macroexpansion
102 ;; ; Now the DEFTRANSFORM doesn't exist in the target Lisp.
103 ;; However, it's continuable because it might be useful to do
104 ;; it when testing new optimization stuff interactively.
105 (cerror "Go ahead, overwrite it."
106 "~@<overwriting old FUN-INFO ~2I~_~S ~I~_for ~S~:>"
107 old-fun-info name
))))
108 (setf (info :function
:type name
) ctype
)
109 (setf (info :function
:where-from name
) :declared
)
110 (setf (info :function
:kind name
) :function
)
111 (setf (info :function
:info name
) info
)
113 (setf (getf (info :source-location
:declaration name
) 'defknown
)
115 (remf (info :source-location
:declaration name
) 'defknown
))))
118 ;;; Return the FUN-INFO for NAME or die trying. Since this is
119 ;;; used by callers who want to modify the info, and the info may be
120 ;;; shared, we copy it. We don't have to copy the lists, since each
121 ;;; function that has generators or transforms has already been
124 ;;; Note that this operation is somewhat garbage-producing in the current
125 ;;; globaldb implementation. Setting a piece of INFO for a name makes
126 ;;; a shallow copy of the name's info-vector. FUN-INFO-OR-LOSE sounds
127 ;;; like a data reader, and you might be disinclined to think that it
128 ;;; copies at all, but:
129 ;;; (TIME (LOOP REPEAT 1000 COUNT (FUN-INFO-OR-LOSE '*)))
130 ;;; 294,160 bytes consed
131 ;;; whereas just copying the info per se is not half as bad:
132 ;;; (LET ((X (INFO :FUNCTION :INFO '*)))
133 ;;; (TIME (LOOP REPEAT 1000 COUNT (COPY-FUN-INFO X))))
134 ;;; 130,992 bytes consed
136 (declaim (ftype (sfunction (t) fun-info
) fun-info-or-lose
))
137 (defun fun-info-or-lose (name)
138 (let ((old (info :function
:info name
)))
139 (unless old
(error "~S is not a known function." name
))
140 (setf (info :function
:info name
) (copy-fun-info old
))))
142 ;;;; generic type inference methods
144 ;;; Derive the type to be the type of the xxx'th arg. This can normally
145 ;;; only be done when the result value is that argument.
146 (defun result-type-first-arg (call)
147 (declare (type combination call
))
148 (let ((lvar (first (combination-args call
))))
149 (when lvar
(lvar-type lvar
))))
150 (defun result-type-last-arg (call)
151 (declare (type combination call
))
152 (let ((lvar (car (last (combination-args call
)))))
153 (when lvar
(lvar-type lvar
))))
155 ;;; Derive the result type according to the float contagion rules, but
156 ;;; always return a float. This is used for irrational functions that
157 ;;; preserve realness of their arguments.
158 (defun result-type-float-contagion (call)
159 (declare (type combination call
))
160 (reduce #'numeric-contagion
(combination-args call
)
162 :initial-value
(specifier-type 'single-float
)))
164 ;;; Return a closure usable as a derive-type method for accessing the
165 ;;; N'th argument. If arg is a list, result is a list. If arg is a
166 ;;; vector, result is a vector with the same element type.
167 (defun sequence-result-nth-arg (n)
169 (declare (type combination call
))
170 (let ((lvar (nth (1- n
) (combination-args call
))))
172 (let ((type (lvar-type lvar
)))
173 (if (array-type-p type
)
175 `(vector ,(type-specifier (array-type-element-type type
))))
176 (let ((ltype (specifier-type 'list
)))
177 (when (csubtypep type ltype
)
180 ;;; Derive the type to be the type specifier which is the Nth arg.
181 (defun result-type-specifier-nth-arg (n)
183 (declare (type combination call
))
184 (let ((lvar (nth (1- n
) (combination-args call
))))
185 (when (and lvar
(constant-lvar-p lvar
))
186 (careful-specifier-type (lvar-value lvar
))))))
188 ;;; Derive the type to be the type specifier which is the Nth arg,
189 ;;; with the additional restriptions noted in the CLHS for STRING and
190 ;;; SIMPLE-STRING, defined to specialize on CHARACTER, and for VECTOR
191 ;;; (under the page for MAKE-SEQUENCE).
192 ;;; At present this is used to derive the output type of CONCATENATE,
193 ;;; MAKE-SEQUENCE, and MERGE. Two things seem slightly amiss:
194 ;;; 1. The sequence type actually produced might not be exactly that specified.
195 ;;; (TYPE-OF (MAKE-SEQUENCE '(AND (NOT SIMPLE-ARRAY) (VECTOR BIT)) 9))
196 ;;; => (SIMPLE-BIT-VECTOR 9)
197 ;;; 2. Because we *know* that a hairy array won't be produced,
198 ;;; why does derivation preserve the non-simpleness, if so specified?
199 (defun creation-result-type-specifier-nth-arg (n)
201 (declare (type combination call
))
202 (let ((lvar (nth (1- n
) (combination-args call
))))
203 (when (and lvar
(constant-lvar-p lvar
))
204 (let* ((specifier (lvar-value lvar
))
205 (lspecifier (if (atom specifier
) (list specifier
) specifier
)))
207 ((eq (car lspecifier
) 'string
)
208 (destructuring-bind (string &rest size
)
210 (declare (ignore string
))
211 (careful-specifier-type
212 `(vector character
,@(when size size
)))))
213 ((eq (car lspecifier
) 'simple-string
)
214 (destructuring-bind (simple-string &rest size
)
216 (declare (ignore simple-string
))
217 (careful-specifier-type
218 `(simple-array character
,@(if size
(list size
) '((*)))))))
220 (let ((ctype (careful-specifier-type specifier
)))
221 (if (and (array-type-p ctype
)
222 (eq (array-type-specialized-element-type ctype
)
224 (make-array-type (array-type-dimensions ctype
)
225 :complexp
(array-type-complexp ctype
)
226 :element-type
*universal-type
*
227 :specialized-element-type
*universal-type
*)
230 (defun remove-non-constants-and-nils (fun)
232 (remove-if-not #'lvar-value
233 (remove-if-not #'constant-lvar-p
(funcall fun list
)))))
235 ;;; FIXME: bad name (first because it uses 1-based indexing; second
236 ;;; because it doesn't get the nth constant arguments)
237 (defun nth-constant-args (&rest indices
)
241 (list list
(cdr list
))
243 ((null indices
) (nreverse result
))
244 (when (= i
(car indices
))
245 (when (constant-lvar-p (car list
))
246 (push (car list
) result
))
247 (setf indices
(cdr indices
)))))))
249 ;;; FIXME: a number of the sequence functions not only do not destroy
250 ;;; their argument if it is empty, but also leave it alone if :start
251 ;;; and :end bound a null sequence, or if :count is 0. This test is a
252 ;;; bit complicated to implement, verging on the impossible, but for
253 ;;; extra points (fill #\1 "abc" :start 0 :end 0) should not cause a
255 (defun nth-constant-nonempty-sequence-args (&rest indices
)
259 (list list
(cdr list
))
261 ((null indices
) (nreverse result
))
262 (when (= i
(car indices
))
263 (when (constant-lvar-p (car list
))
264 (let ((value (lvar-value (car list
))))
265 (unless (or (typep value
'null
)
266 (typep value
'(vector * 0)))
267 (push (car list
) result
))))
268 (setf indices
(cdr indices
)))))))
270 (defun read-elt-type-deriver (skip-arg-p element-type-spec no-hang
)
272 (let* ((element-type (specifier-type element-type-spec
))
273 (null-type (specifier-type 'null
))
274 (err-args (if skip-arg-p
; for PEEK-CHAR, skip 'peek-type' + 'stream'
275 (cddr (combination-args call
))
276 (cdr (combination-args call
)))) ; else just 'stream'
277 (eof-error-p (first err-args
))
278 (eof-value (second err-args
))
279 (unexceptional-type ; the normally returned thing
281 (types-equal-or-intersect (lvar-type eof-error-p
)
283 ;; (READ-elt stream nil <x>) returns (OR (EQL <x>) elt-type)
284 (type-union (if eof-value
(lvar-type eof-value
) null-type
)
286 ;; If eof-error is unsupplied, or was but couldn't be nil
289 (type-union unexceptional-type null-type
)
290 unexceptional-type
))))
292 (defun count/position-max-value
(call)
293 (declare (type combination call
))
294 ;; Could possibly constrain the result more highly if
295 ;; the :start/:end were provided and of known types.
296 (labels ((max-dim (type)
297 ;; This can deal with just enough hair to handle type STRING,
298 ;; but might be made to use GENERIC-ABSTRACT-TYPE-FUNCTION
299 ;; if we really want to be more clever.
301 (union-type (reduce #'max2
(union-type-types type
)
303 (array-type (if (and (not (array-type-complexp type
))
304 (singleton-p (array-type-dimensions type
)))
305 (first (array-type-dimensions type
))
309 (if (and (integerp a
) (integerp b
)) (max a b
) '*)))
310 ;; If type derivation were able to notice that non-simple arrays can
311 ;; be mutated (changing the type), we could safely use LVAR-TYPE on
312 ;; any vector type. But it doesn't notice.
313 ;; We could use LVAR-CONSERVATIVE-TYPE to get a conservative answer.
314 ;; However that's probably not an important use, so the above
315 ;; logic restricts itself to simple arrays.
316 (max-dim (lvar-type (second (combination-args call
))))))
318 (defun position-derive-type (call)
319 (let ((dim (count/position-max-value call
)))
321 (specifier-type `(or (integer 0 (,dim
)) null
)))))
322 (defun count-derive-type (call)
323 (let ((dim (count/position-max-value call
)))
325 (specifier-type `(integer 0 ,dim
)))))
327 (/show0
"knownfun.lisp end of file")