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