x86-64: Better printing of FS: prefix
[sbcl.git] / src / compiler / array-tran.lisp
blob1616c271720e7f17e7b215fabff938f5892f876a
1 ;;;; array-specific optimizers and transforms
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.
12 (in-package "SB!C")
14 ;;;; utilities for optimizing array operations
16 ;;; Return UPGRADED-ARRAY-ELEMENT-TYPE for LVAR, or do
17 ;;; GIVE-UP-IR1-TRANSFORM if the upgraded element type can't be
18 ;;; determined.
19 (defun upgraded-element-type-specifier-or-give-up (lvar)
20 (let ((element-type-specifier (upgraded-element-type-specifier lvar)))
21 (if (eq element-type-specifier '*)
22 (give-up-ir1-transform
23 "upgraded array element type not known at compile time")
24 element-type-specifier)))
26 (defun upgraded-element-type-specifier (lvar)
27 (type-specifier (array-type-upgraded-element-type (lvar-type lvar))))
29 ;;; Array access functions return an object from the array, hence its type is
30 ;;; going to be the array upgraded element type. Secondary return value is the
31 ;;; known supertype of the upgraded-array-element-type, if if the exact
32 ;;; U-A-E-T is not known. (If it is NIL, the primary return value is as good
33 ;;; as it gets.)
34 (defun array-type-upgraded-element-type (type)
35 (typecase type
36 ;; Note that this IF mightn't be satisfied even if the runtime
37 ;; value is known to be a subtype of some specialized ARRAY, because
38 ;; we can have values declared e.g. (AND SIMPLE-VECTOR UNKNOWN-TYPE),
39 ;; which are represented in the compiler as INTERSECTION-TYPE, not
40 ;; array type.
41 (array-type
42 (values (array-type-specialized-element-type type) nil))
43 ;; Deal with intersection types (bug #316078)
44 (intersection-type
45 (let ((intersection-types (intersection-type-types type))
46 (element-type *wild-type*)
47 (element-supertypes nil))
48 (dolist (intersection-type intersection-types)
49 (multiple-value-bind (cur-type cur-supertype)
50 (array-type-upgraded-element-type intersection-type)
51 ;; According to ANSI, an array may have only one specialized
52 ;; element type - e.g. '(and (array foo) (array bar))
53 ;; is not a valid type unless foo and bar upgrade to the
54 ;; same element type.
55 (cond
56 ((eq cur-type *wild-type*)
57 nil)
58 ((eq element-type *wild-type*)
59 (setf element-type cur-type))
60 ((or (not (csubtypep cur-type element-type))
61 (not (csubtypep element-type cur-type)))
62 ;; At least two different element types where given, the array
63 ;; is valid iff they represent the same type.
65 ;; FIXME: TYPE-INTERSECTION already takes care of disjoint array
66 ;; types, so I believe this code should be unreachable. Maybe
67 ;; signal a warning / error instead?
68 (setf element-type *empty-type*)))
69 (push (or cur-supertype (type-*-to-t cur-type))
70 element-supertypes)))
71 (values element-type
72 (when (and (eq *wild-type* element-type) element-supertypes)
73 (apply #'type-intersection element-supertypes)))))
74 (union-type
75 (let ((union-types (union-type-types type))
76 (element-type nil)
77 (element-supertypes nil))
78 (dolist (union-type union-types)
79 (multiple-value-bind (cur-type cur-supertype)
80 (array-type-upgraded-element-type union-type)
81 (cond
82 ((eq element-type *wild-type*)
83 nil)
84 ((eq element-type nil)
85 (setf element-type cur-type))
86 ((or (eq cur-type *wild-type*)
87 ;; If each of the two following tests fail, it is not
88 ;; possible to determine the element-type of the array
89 ;; because more than one kind of element-type was provided
90 ;; like in '(or (array foo) (array bar)) although a
91 ;; supertype (or foo bar) may be provided as the second
92 ;; returned value returned. See also the KLUDGE below.
93 (not (csubtypep cur-type element-type))
94 (not (csubtypep element-type cur-type)))
95 (setf element-type *wild-type*)))
96 (push (or cur-supertype (type-*-to-t cur-type))
97 element-supertypes)))
98 (values element-type
99 (when (eq *wild-type* element-type)
100 (apply #'type-union element-supertypes)))))
101 (member-type
102 ;; Convert member-type to an union-type.
103 (array-type-upgraded-element-type
104 (apply #'type-union (mapcar #'ctype-of (member-type-members type)))))
106 ;; KLUDGE: there is no good answer here, but at least
107 ;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be
108 ;; erroneously optimized (see generic/vm-tran.lisp) -- CSR,
109 ;; 2002-08-21
110 (values *wild-type* nil))))
112 (defun array-type-declared-element-type (type)
113 (if (array-type-p type)
114 (array-type-element-type type)
115 *wild-type*))
117 ;;; The ``new-value'' for array setters must fit in the array, and the
118 ;;; return type is going to be the same as the new-value for SETF
119 ;;; functions.
120 (defun assert-new-value-type (new-value array)
121 (let ((type (lvar-type array)))
122 (when (array-type-p type)
123 (assert-lvar-type
124 new-value
125 (array-type-specialized-element-type type)
126 (lexenv-policy (node-lexenv (lvar-dest new-value)))
127 :aref)))
128 (lvar-type new-value))
130 ;;; Return true if ARG is NIL, or is a constant-lvar whose
131 ;;; value is NIL, false otherwise.
132 (defun unsupplied-or-nil (arg)
133 (declare (type (or lvar null) arg))
134 (or (not arg)
135 (and (constant-lvar-p arg)
136 (not (lvar-value arg)))))
138 (defun supplied-and-true (arg)
139 (and arg
140 (constant-lvar-p arg)
141 (lvar-value arg)
144 ;;;; DERIVE-TYPE optimizers
146 (defun derive-aref-type (array)
147 (multiple-value-bind (uaet other)
148 (array-type-upgraded-element-type (lvar-type array))
149 (or other uaet)))
151 (deftransform array-in-bounds-p ((array &rest subscripts))
152 (block nil
153 (flet ((give-up (&optional reason)
154 (cond ((= (length subscripts) 1)
155 (let ((arg (sb!xc:gensym)))
156 `(lambda (array ,arg)
157 (and (typep ,arg '(and fixnum unsigned-byte))
158 (< ,arg (array-dimension array 0))))))
160 (give-up-ir1-transform
161 (or reason
162 "~@<lower array bounds unknown or negative and upper bounds not ~
163 negative~:@>")))))
164 (bound-known-p (x)
165 (integerp x))) ; might be NIL or *
166 (let ((dimensions (catch-give-up-ir1-transform
167 ((array-type-dimensions-or-give-up
168 (lvar-conservative-type array))
169 args)
170 (give-up (car args)))))
171 ;; Might be *. (Note: currently this is never true, because the type
172 ;; derivation infers the rank from the call to ARRAY-IN-BOUNDS-P, but
173 ;; let's keep this future proof.)
174 (when (eq '* dimensions)
175 (give-up "array bounds unknown"))
176 ;; shortcut for zero dimensions
177 (when (some (lambda (dim)
178 (and (bound-known-p dim) (zerop dim)))
179 dimensions)
180 (return nil))
181 ;; we first collect the subscripts LVARs' bounds and see whether
182 ;; we can already decide on the result of the optimization without
183 ;; even taking a look at the dimensions.
184 (flet ((subscript-bounds (subscript)
185 (let* ((type1 (lvar-type subscript))
186 (type2 (if (csubtypep type1 (specifier-type 'integer))
187 (weaken-integer-type type1 :range-only t)
188 (give-up)))
189 (low (if (integer-type-p type2)
190 (numeric-type-low type2)
191 (give-up)))
192 (high (numeric-type-high type2)))
193 (cond
194 ((and (or (not (bound-known-p low)) (minusp low))
195 (or (not (bound-known-p high)) (not (minusp high))))
196 ;; can't be sure about the lower bound and the upper bound
197 ;; does not give us a definite clue either.
198 (give-up))
199 ((and (bound-known-p high) (minusp high))
200 (return nil)) ; definitely below lower bound (zero).
202 (cons low high))))))
203 (let* ((subscripts-bounds (mapcar #'subscript-bounds subscripts))
204 (subscripts-lower-bound (mapcar #'car subscripts-bounds))
205 (subscripts-upper-bound (mapcar #'cdr subscripts-bounds))
206 (in-bounds 0))
207 (mapcar (lambda (low high dim)
208 (cond
209 ;; first deal with infinite bounds
210 ((some (complement #'bound-known-p) (list low high dim))
211 (when (and (bound-known-p dim) (bound-known-p low) (<= dim low))
212 (return nil)))
213 ;; now we know all bounds
214 ((>= low dim)
215 (return nil))
216 ((< high dim)
217 (aver (not (minusp low)))
218 (incf in-bounds))
220 (give-up))))
221 subscripts-lower-bound
222 subscripts-upper-bound
223 dimensions)
224 (if (eql in-bounds (length dimensions))
226 (give-up))))))))
228 (defoptimizer (aref derive-type) ((array &rest subscripts))
229 (declare (ignore subscripts))
230 (derive-aref-type array))
232 (defoptimizer ((setf aref) derive-type) ((new-value array &rest subscripts))
233 (declare (ignore subscripts))
234 (assert-new-value-type new-value array))
236 (macrolet ((define (name)
237 `(defoptimizer (,name derive-type) ((array index))
238 (declare (ignore index))
239 (derive-aref-type array))))
240 (define hairy-data-vector-ref)
241 (define hairy-data-vector-ref/check-bounds)
242 (define data-vector-ref))
244 #!+(or x86 x86-64)
245 (defoptimizer (data-vector-ref-with-offset derive-type) ((array index offset))
246 (declare (ignore index offset))
247 (derive-aref-type array))
249 (defoptimizer (vector-pop derive-type) ((array))
250 (derive-aref-type array))
252 (macrolet ((define (name)
253 `(defoptimizer (,name derive-type) ((array index new-value))
254 (declare (ignore index))
255 (assert-new-value-type new-value array))))
256 (define hairy-data-vector-set)
257 (define hairy-data-vector-set/check-bounds)
258 (define data-vector-set))
260 #!+(or x86 x86-64)
261 (defoptimizer (data-vector-set-with-offset derive-type) ((array index offset new-value))
262 (declare (ignore index offset))
263 (assert-new-value-type new-value array))
265 ;;; Figure out the type of the data vector if we know the argument
266 ;;; element type.
267 (defun derive-%with-array-data/mumble-type (array)
268 (let ((atype (lvar-type array)))
269 (when (array-type-p atype)
270 (specifier-type
271 `(simple-array ,(type-specifier
272 (array-type-specialized-element-type atype))
273 (*))))))
274 (defoptimizer (%with-array-data derive-type) ((array start end))
275 (declare (ignore start end))
276 (derive-%with-array-data/mumble-type array))
277 (defoptimizer (%with-array-data/fp derive-type) ((array start end))
278 (declare (ignore start end))
279 (derive-%with-array-data/mumble-type array))
281 (defoptimizer (row-major-aref derive-type) ((array index))
282 (declare (ignore index))
283 (derive-aref-type array))
285 (defoptimizer (%set-row-major-aref derive-type) ((array index new-value))
286 (declare (ignore index))
287 (assert-new-value-type new-value array))
289 (defun derive-make-array-type (dims element-type adjustable
290 fill-pointer displaced-to)
291 (let* ((simple (and (unsupplied-or-nil adjustable)
292 (unsupplied-or-nil displaced-to)
293 (unsupplied-or-nil fill-pointer)))
294 (spec
295 (or `(,(if simple 'simple-array 'array)
296 ,(cond ((not element-type) t)
297 ((ctype-p element-type)
298 (type-specifier element-type))
299 ((constant-lvar-p element-type)
300 (let ((ctype (careful-specifier-type
301 (lvar-value element-type))))
302 (cond
303 ((or (null ctype) (contains-unknown-type-p ctype)) '*)
304 (t (sb!xc:upgraded-array-element-type
305 (lvar-value element-type))))))
307 '*))
308 ,(cond ((constant-lvar-p dims)
309 (let* ((val (lvar-value dims))
310 (cdims (ensure-list val)))
311 (if simple
312 cdims
313 (length cdims))))
314 ((csubtypep (lvar-type dims)
315 (specifier-type 'integer))
316 '(*))
318 '*)))
319 'array)))
320 (if (and (not simple)
321 (or (supplied-and-true adjustable)
322 (supplied-and-true displaced-to)
323 (supplied-and-true fill-pointer)))
324 (careful-specifier-type `(and ,spec (not simple-array)))
325 (careful-specifier-type spec))))
327 (defoptimizer (make-array derive-type)
328 ((dims &key element-type adjustable fill-pointer displaced-to
329 &allow-other-keys))
330 (derive-make-array-type dims element-type adjustable
331 fill-pointer displaced-to))
333 (defoptimizer (%make-array derive-type)
334 ((dims widetag n-bits &key adjustable fill-pointer displaced-to
335 &allow-other-keys))
336 (declare (ignore n-bits))
337 (let ((saetp (and (constant-lvar-p widetag)
338 (find (lvar-value widetag)
339 sb!vm:*specialized-array-element-type-properties*
340 :key #'sb!vm:saetp-typecode))))
341 (derive-make-array-type dims (if saetp
342 (sb!vm:saetp-ctype saetp)
343 *wild-type*)
344 adjustable fill-pointer displaced-to)))
347 ;;;; constructors
349 ;;; Convert VECTOR into a MAKE-ARRAY.
350 (define-source-transform vector (&rest elements)
351 `(make-array ,(length elements) :initial-contents (list ,@elements)))
353 ;;; Just convert it into a MAKE-ARRAY.
354 (deftransform make-string ((length &key
355 (element-type 'character)
356 (initial-element
357 #.*default-init-char-form*)))
358 `(the simple-string (make-array (the index length)
359 :element-type element-type
360 ,@(when initial-element
361 '(:initial-element initial-element)))))
363 ;; Traverse the :INTIAL-CONTENTS argument to an array constructor call,
364 ;; changing the skeleton of the data to be constructed by calls to LIST
365 ;; and wrapping some declarations around each array cell's constructor.
366 ;; In general, if we fail to optimize out the materialization
367 ;; of initial-contents as distinct from the array itself, we prefer VECTOR
368 ;; over LIST due to the smaller overhead (except for <= 1 item).
369 ;; If a macro is involved, expand it before traversing.
370 ;; Known limitations:
371 ;; - inline functions whose behavior is merely to call LIST don't work
372 ;; e.g. :INITIAL-CONTENTS (MY-LIST a b) ; where MY-LIST is inline
373 ;; ; and effectively just (LIST ...)
374 (defun rewrite-initial-contents (rank initial-contents env)
375 ;; If FORM is constant to begin with, we don't want to pessimize it
376 ;; by turning it into a non-literal. That would happen because when
377 ;; optimizing `#(#(foo bar) #(,x ,y)) we convert the whole expression
378 ;; into (VECTOR 'FOO 'BAR X Y), whereas in the unidimensional case
379 ;; it never makes sense to turn #(FOO BAR) into (VECTOR 'FOO 'BAR).
380 (when (or (and (= rank 1) (sb!xc:constantp initial-contents env))
381 ;; If you inhibit inlining these - game over.
382 (fun-lexically-notinline-p 'vector env)
383 (fun-lexically-notinline-p 'list env)
384 (fun-lexically-notinline-p 'list* env))
385 (return-from rewrite-initial-contents (values nil nil)))
386 (let ((dimensions (make-array rank :initial-element nil))
387 (output))
388 (named-let recurse ((form (sb!xc:macroexpand initial-contents env))
389 (axis 0))
390 (flet ((make-list-ctor (tail &optional (prefix nil prefixp) &aux val)
391 (when (and (sb!xc:constantp tail)
392 (or (proper-list-p (setq val (constant-form-value tail env)))
393 (and (vectorp val) (not prefixp))))
394 (setq form
395 (cons 'list
396 (append (butlast prefix)
397 (map 'list (lambda (x) (list 'quote x)) val)))))))
398 ;; Express quasiquotation using only LIST, not LIST*.
399 ;; e.g. `(,A ,B X Y) -> (LIST* A B '(X Y)) -> (LIST A B 'X 'Y)
400 (if (typep form '(cons (eql list*) list))
401 (let* ((cdr (cdr form)) (last (last cdr)))
402 (when (null (cdr last))
403 (make-list-ctor (car last) cdr)))
404 (make-list-ctor form)))
405 (unless (and (typep form '(cons (member list vector)))
406 (do ((items (cdr form))
407 (length 0 (1+ length))
408 (fun (let ((axis (the (mod #.array-rank-limit) (1+ axis))))
409 (if (= axis rank)
410 (lambda (item) (push item output))
411 (lambda (item) (recurse item axis))))))
412 ;; FIXME: warn if the nesting is indisputably wrong
413 ;; such as `((,x ,x) (,x ,x ,x)).
414 ((atom items)
415 (and (null items)
416 (if (aref dimensions axis)
417 (eql length (aref dimensions axis))
418 (setf (aref dimensions axis) length))))
419 (declare (type index length))
420 (funcall fun (pop items))))
421 (return-from rewrite-initial-contents (values nil nil))))
422 (when (some #'null dimensions)
423 ;; Unless it is the rightmost axis, a 0-length subsequence
424 ;; causes a NIL dimension. Give up if that happens.
425 (return-from rewrite-initial-contents (values nil nil)))
426 (setq output (nreverse output))
427 (values
428 ;; If the unaltered INITIAL-CONTENTS were constant, then the flattened
429 ;; form must be too. Turning it back to a self-evaluating object
430 ;; is essential to avoid compile-time blow-up on huge vectors.
431 (if (sb!xc:constantp initial-contents env)
432 (map 'vector (lambda (x) (constant-form-value x env)) output)
433 (let ((f (if (singleton-p output) 'list 'vector)))
434 `(locally (declare (notinline ,f))
435 (,f ,@(mapcar (lambda (x)
436 (cond ((and (symbolp x)
437 (not (nth-value
438 1 (sb!xc:macroexpand-1 x env))))
440 ((sb!xc:constantp x env)
441 `',(constant-form-value x env))
443 `(locally (declare (inline ,f)) ,x))))
444 output)))))
445 (coerce dimensions 'list))))
447 ;;; Prevent open coding :INITIAL-CONTENTS arguments, so that we
448 ;;; can pick them apart in the DEFTRANSFORMS.
449 ;;; (MAKE-ARRAY (LIST dim ...)) for rank != 1 is transformed now.
450 ;;; Waiting around to see if IR1 can deduce that the dims are of type LIST
451 ;;; is ineffective, because by then it's too late to flatten the initial
452 ;;; contents using the correct array rank.
453 ;;; We explicitly avoid handling non-simple arrays (uni- or multi-dimensional)
454 ;;; in this path, mainly due to complications in picking the right widetag.
455 (define-source-transform make-array (dims-form &rest rest &environment env
456 &aux dims dims-constp)
457 (cond ((and (sb!xc:constantp dims-form env)
458 (listp (setq dims (constant-form-value dims-form env)))
459 (not (singleton-p dims))
460 (every (lambda (x) (typep x 'index)) dims))
461 (setq dims-constp t))
462 ((and (cond ((typep (setq dims (sb!xc:macroexpand dims-form env))
463 '(cons (eql list)))
464 (setq dims (cdr dims))
466 ;; `(,X 2 1) -> (LIST* X '(2 1)) for example
467 ((typep dims '(cons (eql list*) cons))
468 (let ((last (car (last dims))))
469 (when (sb!xc:constantp last env)
470 (let ((lastval (constant-form-value last env)))
471 (when (listp lastval)
472 (setq dims (append (butlast (cdr dims)) lastval))
473 t))))))
474 (proper-list-p dims)
475 (not (singleton-p dims)))
476 ;; If you spell '(2 2) as (LIST 2 2), it is constant for purposes of MAKE-ARRAY.
477 (when (every (lambda (x) (sb!xc:constantp x env)) dims)
478 (let ((values (mapcar (lambda (x) (constant-form-value x env)) dims)))
479 (when (every (lambda (x) (typep x 'index)) values)
480 (setq dims values dims-constp t)))))
482 ;; Regardless of dimension, it is always good to flatten :INITIAL-CONTENTS
483 ;; if we can, ensuring that we convert `(,X :A :B) = (LIST* X '(:A :B))
484 ;; into (VECTOR X :A :B) which makes it cons less if not optimized,
485 ;; or cons not at all (not counting the destination array) if optimized.
486 ;; There is no need to transform dimensions of '(<N>) to the integer N.
487 ;; The IR1 transform for list-shaped dims will figure it out.
488 (binding* ((contents (and (evenp (length rest)) (getf rest :initial-contents))
489 :exit-if-null)
490 ;; N-DIMS = 1 can be "technically" wrong, but it doesn't matter.
491 (data (rewrite-initial-contents 1 contents env) :exit-if-null))
492 (setf rest (copy-list rest) (getf rest :initial-contents) data)
493 (return-from make-array `(make-array ,dims-form ,@rest)))
494 (return-from make-array (values nil t))))
495 ;; So now we know that this is a multi-dimensional (or 0-dimensional) array.
496 ;; Parse keywords conservatively, rejecting anything that makes it non-simple,
497 ;; and accepting only a pattern that is likely to occur in practice.
498 ;; e.g we give up on a duplicate keywords rather than bind ignored temps.
499 (let* ((unsupplied '#:unsupplied) (et unsupplied) et-constp et-binding
500 contents element adjustable keys data-dims)
501 (unless (loop (if (null rest) (return t))
502 (if (or (atom rest) (atom (cdr rest))) (return nil))
503 (let ((k (pop rest))
504 (v rest))
505 (pop rest)
506 (case k
507 (:element-type
508 (unless (eq et unsupplied) (return nil))
509 (setq et (car v) et-constp (sb!xc:constantp et env)))
510 (:initial-element
511 (when (or contents element) (return nil))
512 (setq element v))
513 (:initial-contents
514 (when (or contents element) (return nil))
515 (if (not dims) ; If 0-dimensional, use :INITIAL-ELEMENT instead
516 (setq k :initial-element element v)
517 (setq contents v)))
518 (:adjustable ; reject if anything other than literal NIL
519 (when (or adjustable (car v)) (return nil))
520 (setq adjustable v))
522 ;; Reject :FILL-POINTER, :DISPLACED-{TO,INDEX-OFFSET},
523 ;; and non-literal keywords.
524 (return nil)))
525 (unless (member k '(:adjustable))
526 (setq keys (nconc keys (list k (car v)))))))
527 (return-from make-array (values nil t)))
528 (when contents
529 (multiple-value-bind (data shape)
530 (rewrite-initial-contents (length dims) (car contents) env)
531 (cond (shape ; initial-contents will be part of the vector allocation
532 ;; and we aren't messing up keyword arg order.
533 (when (and dims-constp (not (equal shape dims)))
534 ;; This will become a runtime error if the code is executed.
535 (warn "array dimensions are ~A but :INITIAL-CONTENTS dimensions are ~A"
536 dims shape))
537 (setf data-dims shape (getf keys :initial-contents) data))
538 (t ; contents could not be flattened
539 ;; Preserve eval order. The only keyword arg to worry about
540 ;; is :ELEMENT-TYPE. See also the remark at DEFKNOWN FILL-ARRAY.
541 (when (and (eq (car keys) :element-type) (not et-constp))
542 (let ((et-temp (make-symbol "ET")))
543 (setf et-binding `((,et-temp ,et)) (cadr keys) et-temp)))
544 (remf keys :initial-contents)))))
545 (let* ((axis-bindings
546 (unless dims-constp
547 (loop for d in dims for i from 0
548 collect (list (make-symbol (format nil "D~D" i))
549 `(the index ,d)))))
550 (dims (if axis-bindings (mapcar #'car axis-bindings) dims))
551 (size (make-symbol "SIZE"))
552 (alloc-form
553 `(truly-the (simple-array
554 ,(cond ((eq et unsupplied) t)
555 (et-constp (constant-form-value et env))
556 (t '*))
557 ,(if dims-constp dims (length dims)))
558 (make-array-header*
559 ,@(sb!vm::make-array-header-inits
560 `(make-array ,size ,@keys) size dims)))))
561 `(let* (,@axis-bindings ,@et-binding (,size (the index (* ,@dims))))
562 ,(cond ((or (not contents) (and dims-constp (equal dims data-dims)))
563 ;; If no :initial-contents, or definitely correct shape,
564 ;; then just call the constructor.
565 alloc-form)
566 (data-dims ; data are flattened
567 ;; original shape must be asserted to be correct
568 ;; Arguably if the contents have a constant shape,
569 ;; we could cast each individual dimension in its binding form,
570 ;; i.e. (LET* ((#:D0 (THE (EQL <n>) dimension0)) ...)
571 ;; but it seems preferable to imply that the initial contents
572 ;; are wrongly shaped rather than that the array is.
573 `(sb!kernel::check-array-shape ,alloc-form ',data-dims))
574 (t ; could not parse the data
575 `(fill-array ,(car contents) ,alloc-form)))))))
577 (define-source-transform coerce (x type &environment env)
578 (if (and (sb!xc:constantp type env)
579 (proper-list-p x)
580 (memq (car x) '(sb!impl::|List| list
581 sb!impl::|Vector| vector)))
582 (let* ((type (constant-form-value type env))
583 (length (1- (length x)))
584 (ctype (careful-values-specifier-type type)))
585 (if (csubtypep ctype (specifier-type '(array * (*))))
586 (multiple-value-bind (type element-type upgraded had-dimensions)
587 (simplify-vector-type ctype)
588 (declare (ignore type upgraded))
589 (if had-dimensions
590 (values nil t)
591 `(make-array ,length
592 :initial-contents ,x
593 ,@(and (not (eq element-type *universal-type*))
594 (not (eq element-type *wild-type*))
595 `(:element-type ',(type-specifier element-type))))))
596 (values nil t)))
597 (values nil t)))
599 ;;; This baby is a bit of a monster, but it takes care of any MAKE-ARRAY
600 ;;; call which creates a vector with a known element type -- and tries
601 ;;; to do a good job with all the different ways it can happen.
602 (defun transform-make-array-vector (length element-type initial-element
603 initial-contents call
604 &key adjustable fill-pointer)
605 (let* ((c-length (if (lvar-p length)
606 (if (constant-lvar-p length) (lvar-value length))
607 length))
608 (complex (cond ((and (or
609 (not fill-pointer)
610 (and (constant-lvar-p fill-pointer)
611 (null (lvar-value fill-pointer))))
613 (not adjustable)
614 (and
615 (constant-lvar-p adjustable)
616 (null (lvar-value adjustable)))))
617 nil)
618 ((and (constant-lvar-p adjustable)
619 (lvar-value adjustable)))
620 ((and fill-pointer
621 (constant-lvar-p fill-pointer)
622 (lvar-value fill-pointer)))
624 ;; Deciding between complex and simple at
625 ;; run-time would be too much hassle
626 (give-up-ir1-transform))))
627 (elt-spec (if element-type
628 (lvar-value element-type) ; enforces const-ness.
630 (elt-ctype (ir1-transform-specifier-type elt-spec))
631 (saetp (if (unknown-type-p elt-ctype)
632 (give-up-ir1-transform "~S is an unknown type: ~S"
633 :element-type elt-spec)
634 (find-saetp-by-ctype elt-ctype)))
635 (default-initial-element (sb!vm:saetp-initial-element-default saetp))
636 (n-bits (sb!vm:saetp-n-bits saetp))
637 (typecode (sb!vm:saetp-typecode saetp))
638 (n-pad-elements (sb!vm:saetp-n-pad-elements saetp))
639 (n-words-form
640 (if c-length
641 (ceiling (* (+ c-length n-pad-elements) n-bits)
642 sb!vm:n-word-bits)
643 (let ((padded-length-form (if (zerop n-pad-elements)
644 'length
645 `(+ length ,n-pad-elements))))
646 (cond
647 ((= n-bits 0) 0)
648 ((>= n-bits sb!vm:n-word-bits)
649 `(* ,padded-length-form
650 ;; i.e., not RATIO
651 ,(the fixnum (/ n-bits sb!vm:n-word-bits))))
653 (let ((n-elements-per-word (/ sb!vm:n-word-bits n-bits)))
654 (declare (type index n-elements-per-word)) ; i.e., not RATIO
655 `(ceiling (truly-the index ,padded-length-form)
656 ,n-elements-per-word)))))))
657 (data-result-spec
658 `(simple-array ,(sb!vm:saetp-specifier saetp) (,(or c-length '*))))
659 (result-spec
660 (if complex
661 `(and (array ,(sb!vm:saetp-specifier saetp) (*))
662 (not simple-array))
663 `(simple-array
664 ,(sb!vm:saetp-specifier saetp) (,(or c-length '*)))))
665 (data-alloc-form
666 `(truly-the ,data-result-spec
667 (allocate-vector ,typecode
668 ;; If LENGTH is a singleton list,
669 ;; we want to avoid reading it.
670 (the index ,(or c-length 'length))
671 ,n-words-form))))
672 (flet ((eliminate-keywords ()
673 (eliminate-keyword-args
674 call 1
675 '((:element-type element-type)
676 (:initial-contents initial-contents)
677 (:initial-element initial-element)
678 (:adjustable adjustable)
679 (:fill-pointer fill-pointer))))
680 (with-alloc-form (&optional data-wrapper)
681 (when (and c-length
682 fill-pointer
683 (csubtypep (lvar-type fill-pointer) (specifier-type 'index))
684 (not (types-equal-or-intersect (lvar-type fill-pointer)
685 (specifier-type `(integer 0 ,c-length)))))
686 (compiler-warn "Invalid fill-pointer ~s for a vector of length ~s."
687 (type-specifier (lvar-type fill-pointer))
688 c-length)
689 (give-up-ir1-transform))
690 (cond (complex
691 (let* ((constant-fill-pointer-p (constant-lvar-p fill-pointer))
692 (fill-pointer-value (and constant-fill-pointer-p
693 (lvar-value fill-pointer))))
694 `(let ((length (the index ,(or c-length 'length))))
695 (truly-the
696 ,result-spec
697 (make-array-header* ,(or (sb!vm:saetp-complex-typecode saetp)
698 sb!vm:complex-vector-widetag)
699 ;; fill-pointer
700 ,(cond ((eq fill-pointer-value t)
701 'length)
702 (fill-pointer-value)
703 ((and fill-pointer
704 (not constant-fill-pointer-p))
705 `(cond ((or (eq fill-pointer t)
706 (null fill-pointer))
707 length)
708 ((> fill-pointer length)
709 (error "Invalid fill-pointer ~a" fill-pointer))
711 fill-pointer)))
713 'length))
714 ;; fill-pointer-p
715 ,(and fill-pointer
716 `(and fill-pointer t))
717 ;; elements
718 length
719 ;; data
720 (let ((data ,data-alloc-form))
721 ,(or data-wrapper 'data))
722 ;; displacement
724 ;; displaced-p
726 ;; displaced-from
728 ;; dimensions
729 length)))))
730 (data-wrapper
731 (subst data-alloc-form 'data data-wrapper))
733 data-alloc-form))))
734 (cond ((and initial-element initial-contents)
735 (abort-ir1-transform "Both ~S and ~S specified."
736 :initial-contents :initial-element))
737 ;; Case (1)
738 ;; :INITIAL-CONTENTS (LIST ...), (VECTOR ...) and `(1 1 ,x) with a
739 ;; constant LENGTH.
740 ((and initial-contents c-length
741 (lvar-matches initial-contents
742 ;; FIXME: probably don't need all 4 of these now?
743 :fun-names '(list vector
744 sb!impl::|List| sb!impl::|Vector|)
745 :arg-count c-length))
746 (let ((parameters (eliminate-keywords))
747 (elt-vars (make-gensym-list c-length))
748 (lambda-list '(length)))
749 (splice-fun-args initial-contents :any c-length)
750 (dolist (p parameters)
751 (setf lambda-list
752 (append lambda-list
753 (if (eq p 'initial-contents)
754 elt-vars
755 (list p)))))
756 `(lambda ,lambda-list
757 (declare (type ,elt-spec ,@elt-vars)
758 (ignorable ,@lambda-list))
759 ,(with-alloc-form
760 `(initialize-vector data ,@elt-vars)))))
761 ;; Case (2)
762 ;; constant :INITIAL-CONTENTS and LENGTH
763 ((and initial-contents c-length
764 (constant-lvar-p initial-contents)
765 ;; As a practical matter, the initial-contents should not be
766 ;; too long, otherwise the compiler seems to spend forever
767 ;; compiling the lambda with one parameter per item.
768 ;; To make matters worse, the time grows superlinearly,
769 ;; and it's not entirely obvious that passing a constant array
770 ;; of 100x100 things is responsible for such an explosion.
771 (<= (length (lvar-value initial-contents)) 1000))
772 (let ((contents (lvar-value initial-contents)))
773 (unless (= c-length (length contents))
774 (abort-ir1-transform "~S has ~S elements, vector length is ~S."
775 :initial-contents (length contents) c-length))
776 (let ((lambda-list `(length ,@(eliminate-keywords))))
777 `(lambda ,lambda-list
778 (declare (ignorable ,@lambda-list))
779 ,(with-alloc-form
780 `(initialize-vector data
781 ,@(map 'list (lambda (elt)
782 `(the ,elt-spec ',elt))
783 contents)))))))
784 ;; Case (3)
785 ;; any other :INITIAL-CONTENTS
786 (initial-contents
787 (let ((lambda-list `(length ,@(eliminate-keywords))))
788 `(lambda ,lambda-list
789 (declare (ignorable ,@lambda-list))
790 (unless (= (length initial-contents) ,(or c-length 'length))
791 (error "~S has ~D elements, vector length is ~D."
792 :initial-contents (length initial-contents)
793 ,(or c-length 'length)))
794 ,(with-alloc-form
795 `(replace data initial-contents)))))
796 ;; Case (4)
797 ;; :INITIAL-ELEMENT, not EQL to the default
798 ((and initial-element
799 (or (not (constant-lvar-p initial-element))
800 (not (eql default-initial-element (lvar-value initial-element)))))
801 (let ((lambda-list `(length ,@(eliminate-keywords)))
802 (init (if (constant-lvar-p initial-element)
803 (list 'quote (lvar-value initial-element))
804 'initial-element)))
805 `(lambda ,lambda-list
806 (declare (ignorable ,@lambda-list))
807 ,(with-alloc-form
808 `(fill data (the ,elt-spec ,init))))))
809 ;; Case (5)
810 ;; just :ELEMENT-TYPE, or maybe with :INITIAL-ELEMENT EQL to the
811 ;; default
813 #-sb-xc-host
814 (and (and (testable-type-p elt-ctype)
815 (neq elt-ctype *empty-type*)
816 (not (ctypep default-initial-element elt-ctype)))
817 ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE
818 ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If
819 ;; INITIAL-ELEMENT is not supplied, the consequences of later
820 ;; reading an uninitialized element of new-array are undefined,"
821 ;; so this could be legal code as long as the user plans to
822 ;; write before he reads, and if he doesn't we're free to do
823 ;; anything we like. But in case the user doesn't know to write
824 ;; elements before he reads elements (or to read manuals before
825 ;; he writes code:-), we'll signal a STYLE-WARNING in case he
826 ;; didn't realize this.
827 (cond
828 (initial-element
829 (compiler-warn "~S ~S is not a ~S"
830 :initial-element default-initial-element
831 elt-spec))
832 ;; For the default initial element, only warn if
833 ;; any array elements are initialized using it.
834 ((and (not (eql c-length 0))
835 ;; If it's coming from the source transform,
836 ;; then fill-array means it was supplied initial-contents
837 (not (lvar-matches-calls (combination-lvar call)
838 '(make-array-header* fill-array))))
839 (compiler-style-warn "The default initial element ~S is not a ~S."
840 default-initial-element
841 elt-spec))))
842 (let ((lambda-list `(length ,@(eliminate-keywords))))
843 `(lambda ,lambda-list
844 (declare (ignorable ,@lambda-list))
845 ,(with-alloc-form))))))))
847 ;;; IMPORTANT: The order of these three MAKE-ARRAY forms matters: the least
848 ;;; specific must come first, otherwise suboptimal transforms will result for
849 ;;; some forms.
851 (deftransform make-array ((dims &key initial-element initial-contents
852 element-type
853 adjustable fill-pointer
854 displaced-to
855 displaced-index-offset)
856 (t &rest *) *
857 :node node)
858 (delay-ir1-transform node :constraint)
859 (when (and initial-contents initial-element)
860 (compiler-warn "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS")
861 (give-up-ir1-transform))
862 (when (and displaced-index-offset
863 (not displaced-to))
864 (compiler-warn "Can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO")
865 (give-up-ir1-transform))
866 (let ((fp-type (and fill-pointer
867 (lvar-type fill-pointer)) ))
868 (when (and fp-type
869 (csubtypep fp-type (specifier-type '(or index (eql t)))))
870 (let* ((dims (and (constant-lvar-p dims)
871 (lvar-value dims)))
872 (length (cond ((integerp dims)
873 dims)
874 ((singleton-p dims)
875 (car dims)))))
876 (cond ((not dims))
877 ((not length)
878 (compiler-warn "Only vectors can have fill pointers."))
879 ((and (csubtypep fp-type (specifier-type 'index))
880 (not (types-equal-or-intersect fp-type
881 (specifier-type `(integer 0 ,length)))))
882 (compiler-warn "Invalid fill-pointer ~s for a vector of length ~s."
883 (type-specifier fp-type)
884 length))))))
885 (macrolet ((maybe-arg (arg)
886 `(and ,arg `(,,(keywordicate arg) ,',arg))))
887 (let* ((eltype (cond ((not element-type) t)
888 ((not (constant-lvar-p element-type))
889 (give-up-ir1-transform
890 "ELEMENT-TYPE is not constant."))
892 (lvar-value element-type))))
893 (eltype-type (ir1-transform-specifier-type eltype))
894 (saetp (if (unknown-type-p eltype-type)
895 (give-up-ir1-transform
896 "ELEMENT-TYPE ~s is not a known type"
897 eltype-type)
898 (find eltype-type
899 sb!vm:*specialized-array-element-type-properties*
900 :key #'sb!vm:saetp-ctype
901 :test #'csubtypep)))
902 (creation-form `(%make-array
903 dims
904 ,(if saetp
905 (sb!vm:saetp-typecode saetp)
906 (give-up-ir1-transform))
907 ,(sb!vm:saetp-n-bits-shift saetp)
908 ,@(maybe-arg initial-contents)
909 ,@(maybe-arg adjustable)
910 ,@(maybe-arg fill-pointer)
911 ,@(maybe-arg displaced-to)
912 ,@(maybe-arg displaced-index-offset))))
913 (cond ((or (not initial-element)
914 (and (constant-lvar-p initial-element)
915 (eql (lvar-value initial-element)
916 (sb!vm:saetp-initial-element-default saetp))))
917 creation-form)
919 ;; error checking for target, disabled on the host because
920 ;; (CTYPE-OF #\Null) is not possible.
921 #-sb-xc-host
922 (when (constant-lvar-p initial-element)
923 (let ((value (lvar-value initial-element)))
924 (cond
925 ((not (ctypep value (sb!vm:saetp-ctype saetp)))
926 ;; this case will cause an error at runtime, so we'd
927 ;; better WARN about it now.
928 (warn 'array-initial-element-mismatch
929 :format-control "~@<~S is not a ~S (which is the ~
930 ~S of ~S).~@:>"
931 :format-arguments
932 (list
933 value
934 (type-specifier (sb!vm:saetp-ctype saetp))
935 'upgraded-array-element-type
936 eltype)))
937 ((not (ctypep value eltype-type))
938 ;; this case will not cause an error at runtime, but
939 ;; it's still worth STYLE-WARNing about.
940 (compiler-style-warn "~S is not a ~S."
941 value eltype)))))
942 `(let ((array ,creation-form))
943 (multiple-value-bind (vector)
944 (%data-vector-and-index array 0)
945 (fill vector (the ,(sb!vm:saetp-specifier saetp) initial-element)))
946 array))))))
948 ;;; The list type restriction does not ensure that the result will be a
949 ;;; multi-dimensional array. But the lack of adjustable, fill-pointer,
950 ;;; and displaced-to keywords ensures that it will be simple.
951 (deftransform make-array ((dims &key
952 element-type initial-element initial-contents
953 adjustable fill-pointer)
954 (list &key
955 (:element-type (constant-arg *))
956 (:initial-element *)
957 (:initial-contents *)
958 (:adjustable *)
959 (:fill-pointer *))
961 :node call)
962 (block make-array
963 ;; If lvar-use of DIMS is a call to LIST, then it must mean that LIST
964 ;; was declared notinline - because if it weren't, then it would have been
965 ;; source-transformed into CONS - which gives us reason NOT to optimize
966 ;; this call to MAKE-ARRAY. So look for CONS instead of LIST,
967 ;; which means that LIST was *not* declared notinline.
968 (when (and (lvar-matches dims :fun-names '(cons) :arg-count 2)
969 (let ((cdr (second (combination-args (lvar-uses dims)))))
970 (and (constant-lvar-p cdr) (null (lvar-value cdr)))))
971 (let* ((args (splice-fun-args dims :any 2)) ; the args to CONS
972 (dummy (cadr args)))
973 (flush-dest dummy)
974 (setf (combination-args call) (delete dummy (combination-args call)))
975 (return-from make-array
976 (transform-make-array-vector (car args)
977 element-type
978 initial-element
979 initial-contents
980 call
981 :adjustable adjustable
982 :fill-pointer fill-pointer))))
983 (unless (constant-lvar-p dims)
984 (give-up-ir1-transform
985 "The dimension list is not constant; cannot open code array creation."))
986 (let ((dims (lvar-value dims))
987 (element-type-ctype (and (constant-lvar-p element-type)
988 (ir1-transform-specifier-type
989 (lvar-value element-type)))))
990 (when (contains-unknown-type-p element-type-ctype)
991 (give-up-ir1-transform))
992 (unless (every (lambda (x) (typep x '(integer 0))) dims)
993 (give-up-ir1-transform
994 "The dimension list contains something other than an integer: ~S"
995 dims))
996 (cond ((singleton-p dims)
997 (transform-make-array-vector (car dims) element-type
998 initial-element initial-contents call
999 :adjustable adjustable
1000 :fill-pointer fill-pointer))
1001 ((and fill-pointer
1002 (not (and
1003 (constant-lvar-p fill-pointer)
1004 (null (lvar-value fill-pointer)))))
1005 (give-up-ir1-transform))
1007 (let* ((total-size (reduce #'* dims))
1008 (rank (length dims))
1009 (complex (cond ((not adjustable) nil)
1010 ((not (constant-lvar-p adjustable))
1011 (give-up-ir1-transform))
1012 ((lvar-value adjustable))))
1013 (spec `(,(if complex
1014 'array
1015 'simple-array)
1016 ,(cond ((null element-type) t)
1017 (element-type-ctype
1018 (sb!xc:upgraded-array-element-type
1019 (lvar-value element-type)))
1020 (t '*))
1021 ,(make-list rank :initial-element '*))))
1022 `(truly-the ,spec
1023 (make-array-header* ,(if complex
1024 sb!vm:complex-array-widetag
1025 sb!vm:simple-array-widetag)
1026 ;; fill-pointer
1027 ,total-size
1028 ;; fill-pointer-p
1030 ;; elements
1031 ,total-size
1032 ;; data
1033 (let ((data (make-array ,total-size
1034 ,@(when element-type
1035 '(:element-type element-type))
1036 ,@(when initial-element
1037 '(:initial-element initial-element)))))
1038 ,(if initial-contents
1039 ;; FIXME: This is could be open coded at least a bit too
1040 `(fill-data-vector data ',dims initial-contents)
1041 'data))
1042 ;; displacement
1044 ;; displaced-p
1046 ;; displaced-from
1048 ;; dimensions
1049 ,@dims))))))))
1051 (deftransform make-array ((dims &key element-type initial-element initial-contents
1052 adjustable fill-pointer)
1053 (integer &key
1054 (:element-type (constant-arg *))
1055 (:initial-element *)
1056 (:initial-contents *)
1057 (:adjustable *)
1058 (:fill-pointer *))
1060 :node call)
1061 (transform-make-array-vector dims
1062 element-type
1063 initial-element
1064 initial-contents
1065 call
1066 :adjustable adjustable
1067 :fill-pointer fill-pointer))
1069 ;;;; ADJUST-ARRAY
1070 (deftransform adjust-array ((array dims &key displaced-to displaced-index-offset)
1071 (array integer &key
1072 (:displaced-to array)
1073 (:displaced-index-offset *)))
1074 (unless displaced-to
1075 (give-up-ir1-transform))
1076 `(progn
1077 (when (invalid-array-p array)
1078 (invalid-array-error array))
1079 (unless (= 1 (array-rank array))
1080 (error "The number of dimensions is not equal to the rank of the array"))
1081 (unless (eql (array-element-type array) (array-element-type displaced-to))
1082 (error "Can't displace an array of type ~S to another of type ~S"
1083 (array-element-type array) (array-element-type displaced-to)))
1084 (let ((displacement (or displaced-index-offset 0)))
1085 (when (< (array-total-size displaced-to) (+ displacement dims))
1086 (error "The :DISPLACED-TO array is too small"))
1087 (if (adjustable-array-p array)
1088 (let ((nfp (when (array-has-fill-pointer-p array)
1089 (when (> (%array-fill-pointer array) dims)
1090 (error "Cannot ADJUST-ARRAY an array to a size smaller than its fill pointer"))
1091 (%array-fill-pointer array))))
1092 (set-array-header array displaced-to dims nfp
1093 displacement dims t nil))
1094 (make-array dims :element-type (array-element-type array)
1095 :displaced-to displaced-to
1096 ,@(and displaced-index-offset
1097 '(:displaced-index-offset displacement)))))))
1099 ;;;; miscellaneous properties of arrays
1101 ;;; Transforms for various array properties. If the property is know
1102 ;;; at compile time because of a type spec, use that constant value.
1104 ;;; Most of this logic may end up belonging in code/late-type.lisp;
1105 ;;; however, here we also need the -OR-GIVE-UP for the transforms, and
1106 ;;; maybe this is just too sloppy for actual type logic. -- CSR,
1107 ;;; 2004-02-18
1108 (defun array-type-dimensions-or-give-up (type)
1109 (labels ((maybe-array-type-dimensions (type)
1110 (typecase type
1111 (array-type
1112 (array-type-dimensions type))
1113 (union-type
1114 (let* ((types (loop for type in (union-type-types type)
1115 for dimensions = (maybe-array-type-dimensions type)
1116 when (eq dimensions '*)
1118 (return-from maybe-array-type-dimensions '*)
1119 when dimensions
1120 collect it))
1121 (result (car types))
1122 (length (length result))
1123 (complete-match t))
1124 (dolist (other (cdr types))
1125 (when (/= length (length other))
1126 (give-up-ir1-transform
1127 "~@<dimensions of arrays in union type ~S do not match~:@>"
1128 (type-specifier type)))
1129 (unless (equal result other)
1130 (setf complete-match nil)))
1131 (if complete-match
1132 result
1133 (make-list length :initial-element '*))))
1134 (intersection-type
1135 (let* ((types (remove nil (mapcar #'maybe-array-type-dimensions
1136 (intersection-type-types type))))
1137 (result (car types)))
1138 (dolist (other (cdr types) result)
1139 (unless (equal result other)
1140 (abort-ir1-transform
1141 "~@<dimensions of arrays in intersection type ~S do not match~:@>"
1142 (type-specifier type)))))))))
1143 (or (maybe-array-type-dimensions type)
1144 (give-up-ir1-transform
1145 "~@<don't know how to extract array dimensions from type ~S~:@>"
1146 (type-specifier type)))))
1148 (defun conservative-array-type-complexp (type)
1149 (typecase type
1150 (array-type (array-type-complexp type))
1151 (union-type
1152 (let ((types (union-type-types type)))
1153 (aver (> (length types) 1))
1154 (let ((result (conservative-array-type-complexp (car types))))
1155 (dolist (type (cdr types) result)
1156 (unless (eq (conservative-array-type-complexp type) result)
1157 (return-from conservative-array-type-complexp :maybe))))))
1158 ;; FIXME: intersection type
1159 (t :maybe)))
1161 ;; Let type derivation handle constant cases. We only do easy strength
1162 ;; reduction.
1163 (deftransform array-rank ((array) (array) * :node node)
1164 (let ((array-type (lvar-type array)))
1165 (cond ((eq t (and (array-type-p array-type)
1166 (array-type-complexp array-type)))
1167 '(%array-rank array))
1169 (delay-ir1-transform node :constraint)
1170 `(if (array-header-p array)
1171 (%array-rank array)
1172 1)))))
1174 (defun derive-array-rank (ctype)
1175 (let ((array (specifier-type 'array)))
1176 (flet ((over (x)
1177 (cond ((not (types-equal-or-intersect x array))
1178 '()) ; Definitely not an array!
1179 ((array-type-p x)
1180 (let ((dims (array-type-dimensions x)))
1181 (if (eql dims '*)
1183 (list (length dims)))))
1184 (t '*)))
1185 (under (x)
1186 ;; Might as well catch some easy negation cases.
1187 (typecase x
1188 (array-type
1189 (let ((dims (array-type-dimensions x)))
1190 (cond ((eql dims '*)
1192 ((every (lambda (dim)
1193 (eql dim '*))
1194 dims)
1195 (list (length dims)))
1197 '()))))
1198 (t '()))))
1199 (declare (dynamic-extent #'over #'under))
1200 (multiple-value-bind (not-p ranks)
1201 (list-abstract-type-function ctype #'over :under #'under)
1202 (cond ((eql ranks '*)
1203 (aver (not not-p))
1204 nil)
1205 (not-p
1206 (specifier-type `(not (member ,@ranks))))
1208 (specifier-type `(member ,@ranks))))))))
1210 (defoptimizer (array-rank derive-type) ((array))
1211 (derive-array-rank (lvar-type array)))
1213 (defoptimizer (%array-rank derive-type) ((array))
1214 (derive-array-rank (lvar-type array)))
1216 ;;; If we know the dimensions at compile time, just use it. Otherwise,
1217 ;;; if we can tell that the axis is in bounds, convert to
1218 ;;; %ARRAY-DIMENSION (which just indirects the array header) or length
1219 ;;; (if it's simple and a vector).
1220 (deftransform array-dimension ((array axis)
1221 (array index))
1222 (unless (constant-lvar-p axis)
1223 (give-up-ir1-transform "The axis is not constant."))
1224 ;; Dimensions may change thanks to ADJUST-ARRAY, so we need the
1225 ;; conservative type.
1226 (let ((array-type (lvar-conservative-type array))
1227 (axis (lvar-value axis)))
1228 (let ((dims (array-type-dimensions-or-give-up array-type)))
1229 (unless (listp dims)
1230 (give-up-ir1-transform
1231 "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime."))
1232 (unless (> (length dims) axis)
1233 (abort-ir1-transform "The array has dimensions ~S, ~W is too large."
1234 dims
1235 axis))
1236 (let ((dim (nth axis dims)))
1237 (cond ((integerp dim)
1238 dim)
1239 ((= (length dims) 1)
1240 (ecase (conservative-array-type-complexp array-type)
1241 ((t)
1242 '(%array-dimension array 0))
1243 ((nil)
1244 '(vector-length array))
1245 ((:maybe)
1246 `(if (array-header-p array)
1247 (%array-dimension array axis)
1248 (vector-length array)))))
1250 '(%array-dimension array axis)))))))
1252 ;;; If the length has been declared and it's simple, just return it.
1253 (deftransform length ((vector)
1254 ((simple-array * (*))))
1255 (let ((type (lvar-type vector)))
1256 (let ((dims (array-type-dimensions-or-give-up type)))
1257 (unless (and (listp dims) (integerp (car dims)))
1258 (give-up-ir1-transform
1259 "Vector length is unknown, must call LENGTH at runtime."))
1260 (car dims))))
1262 ;;; All vectors can get their length by using VECTOR-LENGTH. If it's
1263 ;;; simple, it will extract the length slot from the vector. It it's
1264 ;;; complex, it will extract the fill pointer slot from the array
1265 ;;; header.
1266 (deftransform length ((vector) (vector))
1267 '(vector-length vector))
1269 ;;; If a simple array with known dimensions, then VECTOR-LENGTH is a
1270 ;;; compile-time constant.
1271 (deftransform vector-length ((vector))
1272 (let ((vtype (lvar-type vector)))
1273 (let ((dim (first (array-type-dimensions-or-give-up vtype))))
1274 (when (eq dim '*)
1275 (give-up-ir1-transform))
1276 (when (conservative-array-type-complexp vtype)
1277 (give-up-ir1-transform))
1278 dim)))
1280 ;;; Again, if we can tell the results from the type, just use it.
1281 ;;; Otherwise, if we know the rank, convert into a computation based
1282 ;;; on array-dimension or %array-available-elements
1283 (deftransform array-total-size ((array) (array))
1284 (let* ((array-type (lvar-type array))
1285 (dims (array-type-dimensions-or-give-up array-type)))
1286 (unless (listp dims)
1287 (give-up-ir1-transform "can't tell the rank at compile time"))
1288 (cond ((not (memq '* dims))
1289 (reduce #'* dims))
1290 ((not (cdr dims))
1291 ;; A vector, can't use LENGTH since this ignores the fill-pointer
1292 `(truly-the index (array-dimension array 0)))
1294 `(%array-available-elements array)))))
1296 ;;; Only complex vectors have fill pointers.
1297 (deftransform array-has-fill-pointer-p ((array))
1298 (let ((array-type (lvar-type array)))
1299 (let ((dims (array-type-dimensions-or-give-up array-type)))
1300 (if (and (listp dims) (not (= (length dims) 1)))
1302 (ecase (conservative-array-type-complexp array-type)
1303 ((t)
1305 ((nil)
1306 nil)
1307 ((:maybe)
1308 (give-up-ir1-transform
1309 "The array type is ambiguous; must call ~
1310 ARRAY-HAS-FILL-POINTER-P at runtime.")))))))
1312 (deftransform check-bound ((array dimension index) * * :node node)
1313 ;; This is simply to avoid multiple evaluation of INDEX by the
1314 ;; translator, it's easier to wrap it in a lambda from DEFTRANSFORM
1315 `(bound-cast array ,(if (constant-lvar-p dimension)
1316 (lvar-value dimension)
1317 'dimension)
1318 index))
1320 ;;;; WITH-ARRAY-DATA
1322 ;;; This checks to see whether the array is simple and the start and
1323 ;;; end are in bounds. If so, it proceeds with those values.
1324 ;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that %WITH-ARRAY-DATA
1325 ;;; may be further optimized.
1327 ;;; Given any ARRAY, bind DATA-VAR to the array's data vector and
1328 ;;; START-VAR and END-VAR to the start and end of the designated
1329 ;;; portion of the data vector. SVALUE and EVALUE are any start and
1330 ;;; end specified to the original operation, and are factored into the
1331 ;;; bindings of START-VAR and END-VAR. OFFSET-VAR is the cumulative
1332 ;;; offset of all displacements encountered, and does not include
1333 ;;; SVALUE.
1335 ;;; When FORCE-INLINE is set, the underlying %WITH-ARRAY-DATA form is
1336 ;;; forced to be inline, overriding the ordinary judgment of the
1337 ;;; %WITH-ARRAY-DATA DEFTRANSFORMs. Ordinarily the DEFTRANSFORMs are
1338 ;;; fairly picky about their arguments, figuring that if you haven't
1339 ;;; bothered to get all your ducks in a row, you probably don't care
1340 ;;; that much about speed anyway! But in some cases it makes sense to
1341 ;;; do type testing inside %WITH-ARRAY-DATA instead of outside, and
1342 ;;; the DEFTRANSFORM can't tell that that's going on, so it can make
1343 ;;; sense to use FORCE-INLINE option in that case.
1344 (sb!xc:defmacro with-array-data (((data-var array &key offset-var)
1345 (start-var &optional (svalue 0))
1346 (end-var &optional (evalue nil))
1347 &key force-inline check-fill-pointer
1348 array-header-p)
1349 &body forms
1350 &environment env)
1351 (once-only ((n-array array)
1352 (n-svalue `(the index ,svalue))
1353 (n-evalue `(the (or index null) ,evalue)))
1354 (let ((check-bounds (policy env (plusp insert-array-bounds-checks))))
1355 `(multiple-value-bind (,data-var
1356 ,start-var
1357 ,end-var
1358 ,@ (when offset-var `(,offset-var)))
1359 (cond ,@(and (not array-header-p)
1360 `(((not (array-header-p ,n-array))
1361 (let ((,n-array ,n-array))
1362 (declare (type vector ,n-array))
1363 ,(once-only ((n-len `(length ,n-array))
1364 (n-end `(or ,n-evalue ,n-len)))
1365 (if check-bounds
1366 `(if (<= 0 ,n-svalue ,n-end ,n-len)
1367 (values (truly-the simple-array ,n-array)
1368 ,n-svalue ,n-end 0)
1369 ,(if check-fill-pointer
1370 `(sequence-bounding-indices-bad-error ,n-array ,n-svalue ,n-evalue)
1371 `(array-bounding-indices-bad-error ,n-array ,n-svalue ,n-evalue)))
1372 `(values (truly-the simple-array ,n-array)
1373 ,n-svalue ,n-end 0)))))))
1375 ,(cond (force-inline
1376 `(%with-array-data-macro ,n-array ,n-svalue ,n-evalue
1377 :check-bounds ,check-bounds
1378 :check-fill-pointer ,check-fill-pointer
1379 :array-header-p t))
1380 (check-fill-pointer
1381 `(%with-array-data/fp ,n-array ,n-svalue ,n-evalue))
1383 `(%with-array-data ,n-array ,n-svalue ,n-evalue)))))
1384 ,@forms))))
1386 ;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in
1387 ;;; DEFTRANSFORMs and DEFUNs.
1388 (sb!xc:defmacro %with-array-data-macro
1389 (array start end &key (element-type '*) check-bounds check-fill-pointer
1390 array-header-p)
1391 (with-unique-names (size defaulted-end data cumulative-offset)
1392 `(let* ((,size ,(cond (check-fill-pointer
1393 `(length (the vector ,array)))
1394 (array-header-p
1395 `(%array-available-elements ,array))
1397 `(array-total-size ,array))))
1398 (,defaulted-end (or ,end ,size)))
1399 ,@ (when check-bounds
1400 `((unless (<= ,start ,defaulted-end ,size)
1401 ,(if check-fill-pointer
1402 `(sequence-bounding-indices-bad-error ,array ,start ,end)
1403 `(array-bounding-indices-bad-error ,array ,start ,end)))))
1404 (do ((,data ,(if array-header-p
1405 `(%array-data ,array)
1406 array)
1407 (%array-data ,data))
1408 (,cumulative-offset ,(if array-header-p
1409 `(%array-displacement ,array)
1411 (truly-the index
1412 (+ ,cumulative-offset
1413 (%array-displacement ,data)))))
1414 ((not (array-header-p ,data))
1415 (values (truly-the (simple-array ,element-type 1) ,data)
1416 (truly-the index (+ ,cumulative-offset ,start))
1417 (truly-the index (+ ,cumulative-offset ,defaulted-end))
1418 ,cumulative-offset))))))
1420 (defun transform-%with-array-data/mumble (array node check-fill-pointer)
1421 (let ((element-type (upgraded-element-type-specifier-or-give-up array))
1422 (type (lvar-type array))
1423 (check-bounds (policy node (plusp insert-array-bounds-checks))))
1424 (if (and (array-type-p type)
1425 (not (array-type-complexp type))
1426 (listp (array-type-dimensions type))
1427 (not (null (cdr (array-type-dimensions type)))))
1428 ;; If it's a simple multidimensional array, then just return
1429 ;; its data vector directly rather than going through
1430 ;; %WITH-ARRAY-DATA-MACRO. SBCL doesn't generally generate
1431 ;; code that would use this currently, but we have encouraged
1432 ;; users to use WITH-ARRAY-DATA and we may use it ourselves at
1433 ;; some point in the future for optimized libraries or
1434 ;; similar.
1435 (if check-bounds
1436 `(let* ((data (truly-the (simple-array ,element-type (*))
1437 (%array-data array)))
1438 (len (length data))
1439 (real-end (or end len)))
1440 (unless (<= 0 start data-end lend)
1441 (sequence-bounding-indices-bad-error array start end))
1442 (values data 0 real-end 0))
1443 `(let ((data (truly-the (simple-array ,element-type (*))
1444 (%array-data array))))
1445 (values data 0 (or end (length data)) 0)))
1446 `(%with-array-data-macro array start end
1447 :check-fill-pointer ,check-fill-pointer
1448 :check-bounds ,check-bounds
1449 :element-type ,element-type))))
1451 ;; It might very well be reasonable to allow general ARRAY here, I
1452 ;; just haven't tried to understand the performance issues involved.
1453 ;; -- WHN, and also CSR 2002-05-26
1454 (deftransform %with-array-data ((array start end)
1455 ((or vector simple-array) index (or index null) t)
1457 :node node
1458 :policy (> speed space))
1459 "inline non-SIMPLE-vector-handling logic"
1460 (transform-%with-array-data/mumble array node nil))
1461 (deftransform %with-array-data/fp ((array start end)
1462 ((or vector simple-array) index (or index null) t)
1464 :node node
1465 :policy (> speed space))
1466 "inline non-SIMPLE-vector-handling logic"
1467 (transform-%with-array-data/mumble array node t))
1469 ;;;; array accessors
1471 ;;; We convert all typed array accessors into AREF and (SETF AREF) with type
1472 ;;; assertions on the array.
1473 (macrolet ((define-bit-frob (reffer simplep)
1474 `(progn
1475 (define-source-transform ,reffer (a &rest i)
1476 `(aref (the (,',(if simplep 'simple-array 'array)
1478 ,(mapcar (constantly '*) i))
1479 ,a) ,@i))
1480 (define-source-transform (setf ,reffer) (value a &rest i)
1481 `(setf (aref (the (,',(if simplep 'simple-array 'array)
1483 ,(mapcar (constantly '*) i))
1484 ,a) ,@i)
1485 ,value)))))
1486 (define-bit-frob sbit t)
1487 (define-bit-frob bit nil))
1489 (macrolet ((define-frob (reffer setter type)
1490 `(progn
1491 (define-source-transform ,reffer (a i)
1492 `(aref (the ,',type ,a) ,i))
1493 (define-source-transform ,setter (a i v)
1494 `(setf (aref (the ,',type ,a) ,i) ,v)))))
1495 (define-frob schar %scharset simple-string)
1496 (define-frob char %charset string))
1498 ;;; We transform SVREF and %SVSET directly into DATA-VECTOR-REF/SET: this is
1499 ;;; around 100 times faster than going through the general-purpose AREF
1500 ;;; transform which ends up doing a lot of work -- and introducing many
1501 ;;; intermediate lambdas, each meaning a new trip through the compiler -- to
1502 ;;; get the same result.
1504 ;;; FIXME: [S]CHAR, and [S]BIT above would almost certainly benefit from a similar
1505 ;;; treatment.
1506 (define-source-transform svref (vector index)
1507 (let ((elt-type (or (when (symbolp vector)
1508 (let ((var (lexenv-find vector vars)))
1509 (when (lambda-var-p var)
1510 (type-specifier
1511 (array-type-declared-element-type (lambda-var-type var))))))
1512 t)))
1513 (with-unique-names (n-vector)
1514 `(let ((,n-vector ,vector))
1515 (the ,elt-type (data-vector-ref
1516 (the simple-vector ,n-vector)
1517 (check-bound ,n-vector (length ,n-vector) ,index)))))))
1519 (define-source-transform %svset (vector index value)
1520 (let ((elt-type (or (when (symbolp vector)
1521 (let ((var (lexenv-find vector vars)))
1522 (when (lambda-var-p var)
1523 (type-specifier
1524 (array-type-declared-element-type (lambda-var-type var))))))
1525 t)))
1526 (with-unique-names (n-vector)
1527 `(let ((,n-vector ,vector))
1528 (truly-the ,elt-type (data-vector-set
1529 (the simple-vector ,n-vector)
1530 (check-bound ,n-vector (length ,n-vector) ,index)
1531 (the ,elt-type ,value)))))))
1533 (macrolet (;; This is a handy macro for computing the row-major index
1534 ;; given a set of indices. We wrap each index with a call
1535 ;; to CHECK-BOUND to ensure that everything works out
1536 ;; correctly. We can wrap all the interior arithmetic with
1537 ;; TRULY-THE INDEX because we know the resultant
1538 ;; row-major index must be an index.
1539 (with-row-major-index ((array indices index &optional new-value)
1540 &rest body)
1541 `(let (n-indices dims)
1542 (dotimes (i (length ,indices))
1543 (push (make-symbol (format nil "INDEX-~D" i)) n-indices)
1544 (push (make-symbol (format nil "DIM-~D" i)) dims))
1545 (setf n-indices (nreverse n-indices))
1546 (setf dims (nreverse dims))
1547 `(lambda (,@',(when new-value (list new-value))
1548 ,',array ,@n-indices)
1549 (declare (ignorable ,',array))
1550 (let* (,@(let ((,index -1))
1551 (mapcar (lambda (name)
1552 `(,name (array-dimension
1553 ,',array
1554 ,(incf ,index))))
1555 dims))
1556 (,',index
1557 ,(if (null dims)
1559 (do* ((dims dims (cdr dims))
1560 (indices n-indices (cdr indices))
1561 (last-dim nil (car dims))
1562 (form `(check-bound ,',array
1563 ,(car dims)
1564 ,(car indices))
1565 `(truly-the
1566 index
1567 (+ (truly-the index
1568 (* ,form
1569 ,last-dim))
1570 (check-bound
1571 ,',array
1572 ,(car dims)
1573 ,(car indices))))))
1574 ((null (cdr dims)) form)))))
1575 ,',@body)))))
1577 ;; Just return the index after computing it.
1578 (deftransform array-row-major-index ((array &rest indices))
1579 (with-row-major-index (array indices index)
1580 index))
1582 ;; Convert AREF and (SETF AREF) into a HAIRY-DATA-VECTOR-REF (or
1583 ;; HAIRY-DATA-VECTOR-SET) with the set of indices replaced with the an
1584 ;; expression for the row major index.
1585 (deftransform aref ((array &rest indices))
1586 (with-row-major-index (array indices index)
1587 (hairy-data-vector-ref array index)))
1589 (deftransform (setf aref) ((new-value array &rest subscripts))
1590 (with-row-major-index (array subscripts index new-value)
1591 (hairy-data-vector-set array index new-value))))
1593 ;; For AREF of vectors we do the bounds checking in the callee. This
1594 ;; lets us do a significantly more efficient check for simple-arrays
1595 ;; without bloating the code. If we already know the type of the array
1596 ;; with sufficient precision, skip directly to DATA-VECTOR-REF.
1597 (deftransform aref ((array index) (t t) * :node node)
1598 (let* ((type (lvar-type array))
1599 (element-ctype (array-type-upgraded-element-type type)))
1600 (cond
1601 ((eq element-ctype *empty-type*)
1602 `(data-nil-vector-ref array index))
1603 ((and (array-type-p type)
1604 (null (array-type-complexp type))
1605 (neq element-ctype *wild-type*)
1606 (eql (length (array-type-dimensions type)) 1))
1607 (let* ((declared-element-ctype (array-type-declared-element-type type))
1608 (bare-form
1609 `(data-vector-ref array
1610 (check-bound array (array-dimension array 0) index))))
1611 (if (type= declared-element-ctype element-ctype)
1612 bare-form
1613 `(the ,(type-specifier declared-element-ctype) ,bare-form))))
1614 ((policy node (zerop insert-array-bounds-checks))
1615 `(hairy-data-vector-ref array index))
1616 (t `(hairy-data-vector-ref/check-bounds array index)))))
1618 (deftransform (setf aref) ((new-value array index) (t t t) * :node node)
1619 (if (policy node (zerop insert-array-bounds-checks))
1620 `(hairy-data-vector-set array index new-value)
1621 `(hairy-data-vector-set/check-bounds array index new-value)))
1623 ;;; But if we find out later that there's some useful type information
1624 ;;; available, switch back to the normal one to give other transforms
1625 ;;; a stab at it.
1626 (macrolet ((define (name transform-to extra extra-type)
1627 (declare (ignore extra-type))
1628 `(deftransform ,name ((array index ,@extra))
1629 (let* ((type (lvar-type array))
1630 (element-type (array-type-upgraded-element-type type))
1631 (declared-type (type-specifier
1632 (array-type-declared-element-type type))))
1633 ;; If an element type has been declared, we want to
1634 ;; use that information it for type checking (even
1635 ;; if the access can't be optimized due to the array
1636 ;; not being simple).
1637 (when (and (eq element-type *wild-type*)
1638 ;; This type logic corresponds to the special
1639 ;; case for strings in HAIRY-DATA-VECTOR-REF
1640 ;; (generic/vm-tran.lisp)
1641 (not (csubtypep type (specifier-type 'simple-string))))
1642 (when (or (not (array-type-p type))
1643 ;; If it's a simple array, we might be able
1644 ;; to inline the access completely.
1645 (not (null (array-type-complexp type))))
1646 (give-up-ir1-transform
1647 "Upgraded element type of array is not known at compile time.")))
1648 ,(if extra
1649 ``(truly-the ,declared-type
1650 (,',transform-to array
1651 (check-bound array
1652 (array-dimension array 0)
1653 index)
1654 (the ,declared-type ,@',extra)))
1655 ``(the ,declared-type
1656 (,',transform-to array
1657 (check-bound array
1658 (array-dimension array 0)
1659 index))))))))
1660 (define hairy-data-vector-ref/check-bounds
1661 hairy-data-vector-ref nil nil)
1662 (define hairy-data-vector-set/check-bounds
1663 hairy-data-vector-set (new-value) (*)))
1665 ;;; Just convert into a HAIRY-DATA-VECTOR-REF (or
1666 ;;; HAIRY-DATA-VECTOR-SET) after checking that the index is inside the
1667 ;;; array total size.
1668 (deftransform row-major-aref ((array index))
1669 `(hairy-data-vector-ref array
1670 (check-bound array (array-total-size array) index)))
1671 (deftransform %set-row-major-aref ((array index new-value))
1672 `(hairy-data-vector-set array
1673 (check-bound array (array-total-size array) index)
1674 new-value))
1676 ;;;; bit-vector array operation canonicalization
1677 ;;;;
1678 ;;;; We convert all bit-vector operations to have the result array
1679 ;;;; specified. This allows any result allocation to be open-coded,
1680 ;;;; and eliminates the need for any VM-dependent transforms to handle
1681 ;;;; these cases.
1683 (macrolet ((def (fun)
1684 `(progn
1685 (deftransform ,fun ((bit-array-1 bit-array-2
1686 &optional result-bit-array)
1687 (bit-vector bit-vector &optional null) *
1688 :policy (>= speed space))
1689 `(,',fun bit-array-1 bit-array-2
1690 (make-array (array-dimension bit-array-1 0) :element-type 'bit)))
1691 ;; If result is T, make it the first arg.
1692 (deftransform ,fun ((bit-array-1 bit-array-2 result-bit-array)
1693 (bit-vector bit-vector (eql t)) *)
1694 `(,',fun bit-array-1 bit-array-2 bit-array-1)))))
1695 (def bit-and)
1696 (def bit-ior)
1697 (def bit-xor)
1698 (def bit-eqv)
1699 (def bit-nand)
1700 (def bit-nor)
1701 (def bit-andc1)
1702 (def bit-andc2)
1703 (def bit-orc1)
1704 (def bit-orc2))
1706 ;;; Similar for BIT-NOT, but there is only one arg...
1707 (deftransform bit-not ((bit-array-1 &optional result-bit-array)
1708 (bit-vector &optional null) *
1709 :policy (>= speed space))
1710 '(bit-not bit-array-1
1711 (make-array (array-dimension bit-array-1 0) :element-type 'bit)))
1712 (deftransform bit-not ((bit-array-1 result-bit-array)
1713 (bit-vector (eql t)))
1714 '(bit-not bit-array-1 bit-array-1))
1716 ;;; Pick off some constant cases.
1717 (defoptimizer (array-header-p derive-type) ((array))
1718 (let ((type (lvar-type array)))
1719 (cond ((not (array-type-p type))
1720 ;; FIXME: use analogue of ARRAY-TYPE-DIMENSIONS-OR-GIVE-UP
1721 nil)
1723 (let ((dims (array-type-dimensions type)))
1724 (cond ((csubtypep type (specifier-type '(simple-array * (*))))
1725 ;; no array header
1726 (specifier-type 'null))
1727 ((and (listp dims) (/= (length dims) 1))
1728 ;; multi-dimensional array, will have a header
1729 (specifier-type '(eql t)))
1730 ((eql (array-type-complexp type) t)
1731 (specifier-type '(eql t)))
1733 nil)))))))