Fix make-sequence type derivation with unknown types.
[sbcl.git] / src / compiler / knownfun.lisp
blob5faaed2abf4e0ac09e34d97f3de473edca77448c
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
7 ;;;; more information.
8 ;;;;
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.
15 (in-package "SB!C")
17 (/show0 "knownfun.lisp 17")
19 ;;;; interfaces to defining macros
21 ;;; an IR1 transform
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
29 ;; FUN-TYPE.)
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))
46 %deftransform))
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))))
56 (cond (old
57 (style-warn 'redefinition-with-deftransform
58 :transform old)
59 (setf (transform-function old) fun
60 (transform-note old) note))
62 (push (make-transform :type ctype :function fun :note note
63 :important important)
64 (fun-info-transforms info))))
65 name))
67 ;;; Make a FUN-INFO structure with the specified type, attributes
68 ;;; and optimizers.
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)))
78 %defknown))
79 (defun %defknown (names type attributes location
80 &key derive-type optimizer destroyed-constant-args result-arg
81 overwrite-fndb-silently
82 foldable-call-check
83 callable-check)
84 (let ((ctype (specifier-type type)))
85 (dolist (name names)
86 (unless overwrite-fndb-silently
87 (let ((old-fun-info (info :function :info name)))
88 (when old-fun-info
89 ;; This is handled as an error because it's generally a bad
90 ;; thing to blow away all the old optimization stuff. It's
91 ;; also a potential source of sneaky bugs:
92 ;; DEFKNOWN FOO
93 ;; DEFTRANSFORM FOO
94 ;; DEFKNOWN FOO ; possibly hidden inside some macroexpansion
95 ;; ; Now the DEFTRANSFORM doesn't exist in the target Lisp.
96 ;; However, it's continuable because it might be useful to do
97 ;; it when testing new optimization stuff interactively.
98 (cerror "Go ahead, overwrite it."
99 "~@<overwriting old FUN-INFO ~2I~_~S ~I~_for ~S~:>"
100 old-fun-info name))))
101 (setf (info :function :type name) ctype)
102 (setf (info :function :where-from name) :declared)
103 (setf (info :function :kind name) :function)
104 (setf (info :function :info name)
105 (make-fun-info :attributes attributes
106 :derive-type derive-type
107 :optimizer optimizer
108 :destroyed-constant-args destroyed-constant-args
109 :result-arg result-arg
110 :foldable-call-check foldable-call-check
111 :callable-check callable-check))
112 (if location
113 (setf (getf (info :source-location :declaration name) 'defknown)
114 location)
115 (remf (info :source-location :declaration name) 'defknown))))
116 names)
118 ;;; Return the FUN-INFO for NAME or die trying.
119 (declaim (ftype (sfunction (t) fun-info) fun-info-or-lose))
120 (defun fun-info-or-lose (name)
121 (or (info :function :info name) (error "~S is not a known function." name)))
123 ;;;; generic type inference methods
125 ;;; Derive the type to be the type of the xxx'th arg. This can normally
126 ;;; only be done when the result value is that argument.
127 (defun result-type-first-arg (call)
128 (declare (type combination call))
129 (let ((lvar (first (combination-args call))))
130 (when lvar (lvar-type lvar))))
131 (defun result-type-last-arg (call)
132 (declare (type combination call))
133 (let ((lvar (car (last (combination-args call)))))
134 (when lvar (lvar-type lvar))))
136 ;;; Derive the result type according to the float contagion rules, but
137 ;;; always return a float. This is used for irrational functions that
138 ;;; preserve realness of their arguments.
139 (defun result-type-float-contagion (call)
140 (declare (type combination call))
141 (reduce #'numeric-contagion (combination-args call)
142 :key #'lvar-type
143 :initial-value (specifier-type 'single-float)))
145 ;;; Return a closure usable as a derive-type method for accessing the
146 ;;; N'th argument. If arg is a list, result is a list. If arg is a
147 ;;; vector, result is a vector with the same element type.
148 (defun sequence-result-nth-arg (n)
149 (lambda (call)
150 (declare (type combination call))
151 (let ((lvar (nth (1- n) (combination-args call))))
152 (when lvar
153 (let ((type (lvar-type lvar)))
154 (if (array-type-p type)
155 (specifier-type
156 `(vector ,(type-specifier (array-type-element-type type))))
157 (let ((ltype (specifier-type 'list)))
158 (when (csubtypep type ltype)
159 ltype))))))))
161 ;;; Derive the type to be the type specifier which is the Nth arg.
162 (defun result-type-specifier-nth-arg (n)
163 (lambda (call)
164 (declare (type combination call))
165 (let ((lvar (nth (1- n) (combination-args call))))
166 (when (and lvar (constant-lvar-p lvar))
167 (careful-specifier-type (lvar-value lvar))))))
169 ;;; Derive the type to be the type specifier which is the Nth arg,
170 ;;; with the additional restriptions noted in the CLHS for STRING and
171 ;;; SIMPLE-STRING, defined to specialize on CHARACTER, and for VECTOR
172 ;;; (under the page for MAKE-SEQUENCE).
173 ;;; At present this is used to derive the output type of CONCATENATE,
174 ;;; MAKE-SEQUENCE, and MERGE. Two things seem slightly amiss:
175 ;;; 1. The sequence type actually produced might not be exactly that specified.
176 ;;; (TYPE-OF (MAKE-SEQUENCE '(AND (NOT SIMPLE-ARRAY) (VECTOR BIT)) 9))
177 ;;; => (SIMPLE-BIT-VECTOR 9)
178 ;;; 2. Because we *know* that a hairy array won't be produced,
179 ;;; why does derivation preserve the non-simpleness, if so specified?
180 (defun creation-result-type-specifier-nth-arg (n)
181 (lambda (call)
182 (declare (type combination call))
183 (let ((lvar (nth (1- n) (combination-args call))))
184 (when (and lvar (constant-lvar-p lvar))
185 (let* ((specifier (lvar-value lvar))
186 (lspecifier (if (atom specifier) (list specifier) specifier)))
187 (cond
188 ((eq (car lspecifier) 'string)
189 (destructuring-bind (string &rest size)
190 lspecifier
191 (declare (ignore string))
192 (careful-specifier-type
193 `(vector character ,@(when size size)))))
194 ((eq (car lspecifier) 'simple-string)
195 (destructuring-bind (simple-string &rest size)
196 lspecifier
197 (declare (ignore simple-string))
198 (careful-specifier-type
199 `(simple-array character ,@(if size (list size) '((*)))))))
201 (let ((ctype (careful-specifier-type specifier)))
202 (cond ((not (array-type-p ctype))
203 ctype)
204 ((unknown-type-p (array-type-element-type ctype))
205 (make-array-type (array-type-dimensions ctype)
206 :complexp (array-type-complexp ctype)
207 :element-type *wild-type*
208 :specialized-element-type *wild-type*))
209 ((eq (array-type-specialized-element-type ctype)
210 *wild-type*)
211 (make-array-type (array-type-dimensions ctype)
212 :complexp (array-type-complexp ctype)
213 :element-type *universal-type*
214 :specialized-element-type *universal-type*))
216 ctype))))))))))
218 (defun remove-non-constants-and-nils (fun)
219 (lambda (list)
220 (remove-if-not #'lvar-value
221 (remove-if-not #'constant-lvar-p (funcall fun list)))))
223 ;;; FIXME: bad name (first because it uses 1-based indexing; second
224 ;;; because it doesn't get the nth constant arguments)
225 (defun nth-constant-args (&rest indices)
226 (lambda (list)
227 (let (result)
228 (do ((i 1 (1+ i))
229 (list list (cdr list))
230 (indices indices))
231 ((null indices) (nreverse result))
232 (when (= i (car indices))
233 (when (constant-lvar-p (car list))
234 (push (car list) result))
235 (setf indices (cdr indices)))))))
237 ;;; FIXME: a number of the sequence functions not only do not destroy
238 ;;; their argument if it is empty, but also leave it alone if :start
239 ;;; and :end bound a null sequence, or if :count is 0. This test is a
240 ;;; bit complicated to implement, verging on the impossible, but for
241 ;;; extra points (fill #\1 "abc" :start 0 :end 0) should not cause a
242 ;;; warning.
243 (defun nth-constant-nonempty-sequence-args (&rest indices)
244 (lambda (list)
245 (let (result)
246 (do ((i 1 (1+ i))
247 (list list (cdr list))
248 (indices indices))
249 ((null indices) (nreverse result))
250 (when (= i (car indices))
251 (when (constant-lvar-p (car list))
252 (let ((value (lvar-value (car list))))
253 (unless (or (typep value 'null)
254 (typep value '(vector * 0)))
255 (push (car list) result))))
256 (setf indices (cdr indices)))))))
258 (defun read-elt-type-deriver (skip-arg-p element-type-spec no-hang)
259 (lambda (call)
260 (let* ((element-type (specifier-type element-type-spec))
261 (null-type (specifier-type 'null))
262 (err-args (if skip-arg-p ; for PEEK-CHAR, skip 'peek-type' + 'stream'
263 (cddr (combination-args call))
264 (cdr (combination-args call)))) ; else just 'stream'
265 (eof-error-p (first err-args))
266 (eof-value (second err-args))
267 (unexceptional-type ; the normally returned thing
268 (if (and eof-error-p
269 (types-equal-or-intersect (lvar-type eof-error-p)
270 null-type))
271 ;; (READ-elt stream nil <x>) returns (OR (EQL <x>) elt-type)
272 (type-union (if eof-value (lvar-type eof-value) null-type)
273 element-type)
274 ;; If eof-error is unsupplied, or was but couldn't be nil
275 element-type)))
276 (if no-hang
277 (type-union unexceptional-type null-type)
278 unexceptional-type))))
280 (defun count/position-max-value (call)
281 (declare (type combination call))
282 ;; Could possibly constrain the result more highly if
283 ;; the :start/:end were provided and of known types.
284 (labels ((max-dim (type)
285 ;; This can deal with just enough hair to handle type STRING,
286 ;; but might be made to use GENERIC-ABSTRACT-TYPE-FUNCTION
287 ;; if we really want to be more clever.
288 (typecase type
289 (union-type (reduce #'max2 (union-type-types type)
290 :key #'max-dim))
291 (array-type (if (and (not (array-type-complexp type))
292 (singleton-p (array-type-dimensions type)))
293 (first (array-type-dimensions type))
294 '*))
295 (t '*)))
296 (max2 (a b)
297 (if (and (integerp a) (integerp b)) (max a b) '*)))
298 ;; If type derivation were able to notice that non-simple arrays can
299 ;; be mutated (changing the type), we could safely use LVAR-TYPE on
300 ;; any vector type. But it doesn't notice.
301 ;; We could use LVAR-CONSERVATIVE-TYPE to get a conservative answer.
302 ;; However that's probably not an important use, so the above
303 ;; logic restricts itself to simple arrays.
304 (max-dim (lvar-type (second (combination-args call))))))
306 (defun position-derive-type (call)
307 (let ((dim (count/position-max-value call)))
308 (when (integerp dim)
309 (specifier-type `(or (integer 0 (,dim)) null)))))
310 (defun count-derive-type (call)
311 (let ((dim (count/position-max-value call)))
312 (when (integerp dim)
313 (specifier-type `(integer 0 ,dim)))))
315 (/show0 "knownfun.lisp end of file")