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.
5
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.
14
15(in-package "SB!C")
16
17(/show0 "knownfun.lisp 17")
18
19;;;; interfaces to defining macros
20
21;;; an IR1 transform
22(defstruct (transform (:copier nil))
23  ;; the function type which enables this transform.
24  ;;
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)))
38
39(defprinter (transform) type note important)
40
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))
45                          *)
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))
61          (t
62           (push (make-transform :type ctype :function fun :note note
63                                 :important important)
64                 (fun-info-transforms info))))
65    name))
66
67;;; Make a FUN-INFO structure with the specified type, attributes
68;;; and optimizers.
69(defun %defknown (names type attributes location
70                  &key derive-type optimizer destroyed-constant-args result-arg
71                       overwrite-fndb-silently
72                       foldable-call-check
73                       callable-check
74                       call-type-deriver
75                       functional-args)
76  (let ((ctype (specifier-type type)))
77    (dolist (name names)
78      (unless overwrite-fndb-silently
79        (let ((old-fun-info (info :function :info name)))
80          (when old-fun-info
81            ;; This is handled as an error because it's generally a bad
82            ;; thing to blow away all the old optimization stuff. It's
83            ;; also a potential source of sneaky bugs:
84            ;;    DEFKNOWN FOO
85            ;;    DEFTRANSFORM FOO
86            ;;    DEFKNOWN FOO ; possibly hidden inside some macroexpansion
87            ;;    ; Now the DEFTRANSFORM doesn't exist in the target Lisp.
88            ;; However, it's continuable because it might be useful to do
89            ;; it when testing new optimization stuff interactively.
90            (cerror "Go ahead, overwrite it."
91                    "~@<overwriting old FUN-INFO ~2I~_~S ~I~_for ~S~:>"
92                    old-fun-info name))))
93      (setf (info :function :type name) ctype)
94      (setf (info :function :where-from name) :declared)
95      (setf (info :function :kind name) :function)
96      (setf (info :function :info name)
97            (make-fun-info :attributes attributes
98                           :derive-type derive-type
99                           :optimizer optimizer
100                           :destroyed-constant-args destroyed-constant-args
101                           :result-arg result-arg
102                           :foldable-call-check foldable-call-check
103                           :callable-check callable-check
104                           :call-type-deriver call-type-deriver
105                           :functional-args functional-args))
106      (if location
107          (setf (getf (info :source-location :declaration name) 'defknown)
108                location)
109          (remf (info :source-location :declaration name) 'defknown))))
110  names)
111
112;;; Return the FUN-INFO for NAME or die trying.
113(declaim (ftype (sfunction (t) fun-info) fun-info-or-lose))
114(defun fun-info-or-lose (name)
115  (or (info :function :info name) (error "~S is not a known function." name)))
116
117;;;; generic type inference methods
118
119;;; Derive the type to be the type of the xxx'th arg. This can normally
120;;; only be done when the result value is that argument.
121(defun result-type-first-arg (call)
122  (declare (type combination call))
123  (let ((lvar (first (combination-args call))))
124    (when lvar (lvar-type lvar))))
125(defun result-type-last-arg (call)
126  (declare (type combination call))
127  (let ((lvar (car (last (combination-args call)))))
128    (when lvar (lvar-type lvar))))
129
130;;; Derive the result type according to the float contagion rules, but
131;;; always return a float. This is used for irrational functions that
132;;; preserve realness of their arguments.
133(defun result-type-float-contagion (call)
134  (declare (type combination call))
135  (reduce #'numeric-contagion (combination-args call)
136          :key #'lvar-type
137          :initial-value (specifier-type 'single-float)))
138
139(defun simplify-list-type (type &key preserve-dimensions)
140  ;; Preserve all the list types without dragging
141  ;; (cons (eql 10)) stuff in.
142  (let ((cons-type (specifier-type 'cons))
143        (list-type (specifier-type 'list))
144        (null-type (specifier-type 'null)))
145    (cond ((and preserve-dimensions
146                (csubtypep type cons-type))
147           cons-type)
148          ((and preserve-dimensions
149                (csubtypep type null-type))
150           null-type)
151          ((csubtypep type list-type)
152           list-type))))
153
154;;; Return a closure usable as a derive-type method for accessing the
155;;; N'th argument. If arg is a list, result is a list. If arg is a
156;;; vector, result is a vector with the same element type.
157(defun sequence-result-nth-arg (n &key preserve-dimensions
158                                       preserve-vector-type)
159  (lambda (call)
160    (declare (type combination call))
161    (let ((lvar (nth (1- n) (combination-args call))))
162      (when lvar
163        (let ((type (lvar-type lvar)))
164          (cond ((simplify-list-type type
165                                     :preserve-dimensions preserve-dimensions))
166                ((not (csubtypep type (specifier-type 'vector)))
167                 nil)
168                (preserve-vector-type
169                 type)
170                (t
171                 (let ((simplified (simplify-vector-type type)))
172                   (if (and preserve-dimensions
173                            (csubtypep simplified (specifier-type 'simple-array)))
174                       (type-intersection (specifier-type
175                                           `(simple-array * ,(ctype-array-dimensions type)))
176                                          simplified)
177                       simplified)))))))))
178
179;;; Derive the type to be the type specifier which is the Nth arg.
180(defun 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        (careful-specifier-type (lvar-value lvar))))))
186
187;;; Derive the type to be the type specifier which is the Nth arg,
188;;; with the additional restriptions noted in the CLHS for STRING and
189;;; SIMPLE-STRING, defined to specialize on CHARACTER, and for VECTOR
190;;; (under the page for MAKE-SEQUENCE).
191;;; At present this is used to derive the output type of CONCATENATE,
192;;; MAKE-SEQUENCE, and MERGE. Two things seem slightly amiss:
193;;; 1. The sequence type actually produced might not be exactly that specified.
194;;;    (TYPE-OF (MAKE-SEQUENCE '(AND (NOT SIMPLE-ARRAY) (VECTOR BIT)) 9))
195;;;    => (SIMPLE-BIT-VECTOR 9)
196;;; 2. Because we *know* that a hairy array won't be produced,
197;;;    why does derivation preserve the non-simpleness, if so specified?
198(defun creation-result-type-specifier-nth-arg (n)
199  (lambda (call)
200    (declare (type combination call))
201    (let ((lvar (nth (1- n) (combination-args call))))
202      (when (and lvar (constant-lvar-p lvar))
203        (let* ((specifier (lvar-value lvar))
204               (lspecifier (if (atom specifier) (list specifier) specifier)))
205          (cond
206            ((eq (car lspecifier) 'string)
207             (destructuring-bind (string &rest size)
208                 lspecifier
209               (declare (ignore string))
210               (careful-specifier-type
211                `(vector character ,@(when size size)))))
212            ((eq (car lspecifier) 'simple-string)
213             (destructuring-bind (simple-string &rest size)
214                 lspecifier
215               (declare (ignore simple-string))
216               (careful-specifier-type
217                `(simple-array character ,@(if size (list size) '((*)))))))
218            (t
219             (let ((ctype (careful-specifier-type specifier)))
220               (cond ((not (array-type-p ctype))
221                      ctype)
222                     ((unknown-type-p (array-type-element-type ctype))
223                      (make-array-type (array-type-dimensions ctype)
224                                       :complexp (array-type-complexp ctype)
225                                       :element-type *wild-type*
226                                       :specialized-element-type *wild-type*))
227                     ((eq (array-type-specialized-element-type ctype)
228                          *wild-type*)
229                      (make-array-type (array-type-dimensions ctype)
230                                       :complexp (array-type-complexp ctype)
231                                       :element-type *universal-type*
232                                       :specialized-element-type *universal-type*))
233                     (t
234                      ctype))))))))))
235
236(defun remove-non-constants-and-nils (fun)
237  (lambda (list)
238    (remove-if-not #'lvar-value
239                   (remove-if-not #'constant-lvar-p (funcall fun list)))))
240
241;;; FIXME: bad name (first because it uses 1-based indexing; second
242;;; because it doesn't get the nth constant arguments)
243(defun nth-constant-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            (push (car list) result))
253          (setf indices (cdr indices)))))))
254
255;;; FIXME: a number of the sequence functions not only do not destroy
256;;; their argument if it is empty, but also leave it alone if :start
257;;; and :end bound a null sequence, or if :count is 0.  This test is a
258;;; bit complicated to implement, verging on the impossible, but for
259;;; extra points (fill #\1 "abc" :start 0 :end 0) should not cause a
260;;; warning.
261(defun nth-constant-nonempty-sequence-args (&rest indices)
262  (lambda (list)
263    (let (result)
264      (do ((i 1 (1+ i))
265           (list list (cdr list))
266           (indices indices))
267          ((null indices) (nreverse result))
268        (when (= i (car indices))
269          (when (constant-lvar-p (car list))
270            (let ((value (lvar-value (car list))))
271              (unless (or (typep value 'null)
272                          (typep value '(vector * 0)))
273                (push (car list) result))))
274          (setf indices (cdr indices)))))))
275
276(defun read-elt-type-deriver (skip-arg-p element-type-spec no-hang)
277  (lambda (call)
278    (let* ((element-type (specifier-type element-type-spec))
279           (null-type (specifier-type 'null))
280           (err-args (if skip-arg-p ; for PEEK-CHAR, skip 'peek-type' + 'stream'
281                         (cddr (combination-args call))
282                         (cdr (combination-args call)))) ; else just 'stream'
283           (eof-error-p (first err-args))
284           (eof-value (second err-args))
285           (unexceptional-type ; the normally returned thing
286            (if (and eof-error-p
287                     (types-equal-or-intersect (lvar-type eof-error-p)
288                                               null-type))
289                ;; (READ-elt stream nil <x>) returns (OR (EQL <x>) elt-type)
290                (type-union (if eof-value (lvar-type eof-value) null-type)
291                            element-type)
292                ;; If eof-error is unsupplied, or was but couldn't be nil
293                element-type)))
294      (if no-hang
295          (type-union unexceptional-type null-type)
296          unexceptional-type))))
297
298;;; Return MAX MIN
299(defun sequence-lvar-dimensions (lvar)
300  (if (not (constant-lvar-p lvar))
301      (let ((max 0) (min array-total-size-limit))
302        (block nil
303          (labels ((max-dim (type)
304                     ;; This can deal with just enough hair to handle type STRING,
305                     ;; but might be made to use GENERIC-ABSTRACT-TYPE-FUNCTION
306                     ;; if we really want to be more clever.
307                     (typecase type
308                       (union-type
309                        (mapc #'max-dim (union-type-types type)))
310                       (array-type (if (array-type-complexp type)
311                                       (return '*)
312                                       (process-dim (array-type-dimensions type))))
313                       (t (return '*))))
314                   (process-dim (dim)
315                     (let ((length (car dim)))
316                       (if (and (singleton-p dim)
317                                (integerp length))
318                           (setf max (max max length)
319                                 min (min min length))
320                           (return '*)))))
321            ;; If type derivation were able to notice that non-simple arrays can
322            ;; be mutated (changing the type), we could safely use LVAR-TYPE on
323            ;; any vector type. But it doesn't notice.
324            ;; We could use LVAR-CONSERVATIVE-TYPE to get a conservative answer.
325            ;; However that's probably not an important use, so the above
326            ;; logic restricts itself to simple arrays.
327            (max-dim (lvar-type lvar))
328            (values max min))))
329      (let ((value (lvar-value lvar)))
330        (and (typep value 'sequence)
331             (let ((length (length value)))
332               (values length length))))))
333
334(defun position-derive-type (call)
335  (let ((dim (sequence-lvar-dimensions (second (combination-args call)))))
336    (when (integerp dim)
337      (specifier-type `(or (integer 0 (,dim)) null)))))
338
339(defun count-derive-type (call)
340  (let ((dim (sequence-lvar-dimensions (second (combination-args call)))))
341    (when (integerp dim)
342      (specifier-type `(integer 0 ,dim)))))
343
344;;; This used to be done in DEFOPTIMIZER DERIVE-TYPE, but
345;;; ASSERT-CALL-TYPE already asserts the ARRAY type, so it gets an extra
346;;; assertion that may not get eliminated and requires extra work.
347(defun array-call-type-deriver (call trusted)
348  (let ((type (lvar-type (combination-fun call)))
349        (policy (lexenv-policy (node-lexenv call)))
350        (args (combination-args call)))
351    (flet ((assert-type (arg type)
352             (when (assert-lvar-type arg type policy)
353               (unless trusted (reoptimize-lvar arg)))))
354      (loop for (type . next) on (fun-type-required type)
355            while next
356            do (assert-type (pop args) type))
357      (assert-type (pop args)
358                   (specifier-type `(array * ,(make-list (length args)
359                                                         :initial-element '*))))
360      (loop for subscript in args
361            do (assert-type subscript (fun-type-rest type))))))
362
363(/show0 "knownfun.lisp end of file")
364