1 ;;;; array-specific optimizers and transforms
3 ;;;; This software is part of the SBCL system. See the README file for
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.
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
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
34 (defun array-type-upgraded-element-type (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
42 (values (array-type-specialized-element-type type
) nil
))
43 ;; Deal with intersection types (bug #316078)
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
56 ((eq cur-type
*wild-type
*)
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
))
72 (when (and (eq *wild-type
* element-type
) element-supertypes
)
73 (apply #'type-intersection element-supertypes
)))))
75 (let ((union-types (union-type-types type
))
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
)
82 ((eq element-type
*wild-type
*)
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
))
99 (when (eq *wild-type
* element-type
)
100 (apply #'type-union element-supertypes
)))))
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,
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
)
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
120 (defun assert-new-value-type (new-value array
)
121 (let ((type (lvar-type array
)))
122 (when (array-type-p type
)
125 (array-type-specialized-element-type type
)
126 (lexenv-policy (node-lexenv (lvar-dest new-value
)))
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
))
135 (and (constant-lvar-p arg
)
136 (not (lvar-value arg
)))))
138 (defun supplied-and-true (arg)
140 (constant-lvar-p 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
))
151 (deftransform array-in-bounds-p
((array &rest subscripts
))
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
162 "~@<lower array bounds unknown or negative and upper bounds not ~
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
))
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
)))
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
)
189 (low (if (integer-type-p type2
)
190 (numeric-type-low type2
)
192 (high (numeric-type-high type2
)))
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.
199 ((and (bound-known-p high
) (minusp high
))
200 (return nil
)) ; definitely below lower bound (zero).
203 (let* ((subscripts-bounds (mapcar #'subscript-bounds subscripts
))
204 (subscripts-lower-bound (mapcar #'car subscripts-bounds
))
205 (subscripts-upper-bound (mapcar #'cdr subscripts-bounds
))
207 (mapcar (lambda (low high dim
)
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
))
213 ;; now we know all bounds
217 (aver (not (minusp low
)))
221 subscripts-lower-bound
222 subscripts-upper-bound
224 (if (eql in-bounds
(length dimensions
))
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
))
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
))
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
267 (defun derive-%with-array-data
/mumble-type
(array)
268 (let ((atype (lvar-type array
)))
269 (when (array-type-p atype
)
271 `(simple-array ,(type-specifier
272 (array-type-specialized-element-type atype
))
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
)))
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
))))
303 ((or (null ctype
) (contains-unknown-type-p ctype
)) '*)
304 (t (sb!xc
:upgraded-array-element-type
305 (lvar-value element-type
))))))
308 ,(cond ((constant-lvar-p dims
)
309 (let* ((val (lvar-value dims
))
310 (cdims (ensure-list val
)))
314 ((csubtypep (lvar-type dims
)
315 (specifier-type 'integer
))
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
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
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
)
344 adjustable fill-pointer displaced-to
)))
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
)
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
))
388 (named-let recurse
((form (sb!xc
:macroexpand initial-contents env
))
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
))))
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
))))
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)).
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
))
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
)
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
))))
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
))
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
))
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
))
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
))
508 (unless (eq et unsupplied
) (return nil
))
509 (setq et
(car v
) et-constp
(sb!xc
:constantp et env
)))
511 (when (or contents element
) (return nil
))
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
)
518 (:adjustable
; reject if anything other than literal NIL
519 (when (or adjustable
(car v
)) (return nil
))
522 ;; Reject :FILL-POINTER, :DISPLACED-{TO,INDEX-OFFSET},
523 ;; and non-literal keywords.
525 (unless (member k
'(:adjustable
))
526 (setq keys
(nconc keys
(list k
(car v
)))))))
527 (return-from make-array
(values nil t
)))
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"
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
547 (loop for d in dims for i from
0
548 collect
(list (make-symbol (format nil
"D~D" i
))
550 (dims (if axis-bindings
(mapcar #'car axis-bindings
) dims
))
551 (size (make-symbol "SIZE"))
553 `(truly-the (simple-array
554 ,(cond ((eq et unsupplied
) t
)
555 (et-constp (constant-form-value et env
))
557 ,(if dims-constp dims
(length dims
)))
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.
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
)
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
))
593 ,@(and (not (eq element-type
*universal-type
*))
594 (not (eq element-type
*wild-type
*))
595 `(:element-type
',(type-specifier element-type
))))))
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
))
608 (complex (cond ((and (or
610 (and (constant-lvar-p fill-pointer
)
611 (null (lvar-value fill-pointer
))))
615 (constant-lvar-p adjustable
)
616 (null (lvar-value adjustable
)))))
618 ((and (constant-lvar-p adjustable
)
619 (lvar-value adjustable
)))
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
))
641 (ceiling (* (+ c-length n-pad-elements
) n-bits
)
643 (let ((padded-length-form (if (zerop n-pad-elements
)
645 `(+ length
,n-pad-elements
))))
648 ((>= n-bits sb
!vm
:n-word-bits
)
649 `(* ,padded-length-form
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
)))))))
658 `(simple-array ,(sb!vm
:saetp-specifier saetp
) (,(or c-length
'*))))
661 `(and (array ,(sb!vm
:saetp-specifier saetp
) (*))
664 ,(sb!vm
:saetp-specifier saetp
) (,(or c-length
'*)))))
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
))
672 (flet ((eliminate-keywords ()
673 (eliminate-keyword-args
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
)
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
))
689 (give-up-ir1-transform))
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
))))
697 (make-array-header* ,(or (sb!vm
:saetp-complex-typecode saetp
)
698 sb
!vm
:complex-vector-widetag
)
700 ,(cond ((eq fill-pointer-value t
)
704 (not constant-fill-pointer-p
))
705 `(cond ((or (eq fill-pointer t
)
708 ((> fill-pointer length
)
709 (error "Invalid fill-pointer ~a" fill-pointer
))
716 `(and fill-pointer t
))
720 (let ((data ,data-alloc-form
))
721 ,(or data-wrapper
'data
))
731 (subst data-alloc-form
'data data-wrapper
))
734 (cond ((and initial-element initial-contents
)
735 (abort-ir1-transform "Both ~S and ~S specified."
736 :initial-contents
:initial-element
))
738 ;; :INITIAL-CONTENTS (LIST ...), (VECTOR ...) and `(1 1 ,x) with a
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
)
753 (if (eq p
'initial-contents
)
756 `(lambda ,lambda-list
757 (declare (type ,elt-spec
,@elt-vars
)
758 (ignorable ,@lambda-list
))
760 `(initialize-vector data
,@elt-vars
)))))
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
))
780 `(initialize-vector data
781 ,@(map 'list
(lambda (elt)
782 `(the ,elt-spec
',elt
))
785 ;; any other :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
)))
795 `(replace data initial-contents
)))))
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
))
805 `(lambda ,lambda-list
806 (declare (ignorable ,@lambda-list
))
808 `(fill data
(the ,elt-spec
,init
))))))
810 ;; just :ELEMENT-TYPE, or maybe with :INITIAL-ELEMENT EQL to the
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.
829 (compiler-warn "~S ~S is not a ~S"
830 :initial-element default-initial-element
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
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
851 (deftransform make-array
((dims &key initial-element initial-contents
853 adjustable fill-pointer
855 displaced-index-offset
)
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
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
)) ))
869 (csubtypep fp-type
(specifier-type '(or index
(eql t
)))))
870 (let* ((dims (and (constant-lvar-p dims
)
872 (length (cond ((integerp dims
)
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
)
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"
899 sb
!vm
:*specialized-array-element-type-properties
*
900 :key
#'sb
!vm
:saetp-ctype
902 (creation-form `(%make-array
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
))))
919 ;; error checking for target, disabled on the host because
920 ;; (CTYPE-OF #\Null) is not possible.
922 (when (constant-lvar-p initial-element
)
923 (let ((value (lvar-value initial-element
)))
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 ~
934 (type-specifier (sb!vm
:saetp-ctype saetp
))
935 'upgraded-array-element-type
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."
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
)))
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
)
955 (:element-type
(constant-arg *))
957 (:initial-contents
*)
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
974 (setf (combination-args call
) (delete dummy
(combination-args call
)))
975 (return-from make-array
976 (transform-make-array-vector (car args
)
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"
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
))
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
1016 ,(cond ((null element-type
) t
)
1018 (sb!xc
:upgraded-array-element-type
1019 (lvar-value element-type
)))
1021 ,(make-list rank
:initial-element
'*))))
1023 (make-array-header* ,(if complex
1024 sb
!vm
:complex-array-widetag
1025 sb
!vm
:simple-array-widetag
)
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
)
1051 (deftransform make-array
((dims &key element-type initial-element initial-contents
1052 adjustable fill-pointer
)
1054 (:element-type
(constant-arg *))
1055 (:initial-element
*)
1056 (:initial-contents
*)
1061 (transform-make-array-vector dims
1066 :adjustable adjustable
1067 :fill-pointer fill-pointer
))
1070 (deftransform adjust-array
((array dims
&key displaced-to displaced-index-offset
)
1072 (:displaced-to array
)
1073 (:displaced-index-offset
*)))
1074 (unless displaced-to
1075 (give-up-ir1-transform))
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,
1108 (defun array-type-dimensions-or-give-up (type)
1109 (labels ((maybe-array-type-dimensions (type)
1112 (array-type-dimensions 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
'*)
1121 (result (car types
))
1122 (length (length result
))
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
)))
1133 (make-list length
:initial-element
'*))))
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)
1150 (array-type (array-type-complexp 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
1161 ;; Let type derivation handle constant cases. We only do easy strength
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
)
1174 (defun derive-array-rank (ctype)
1175 (let ((array (specifier-type 'array
)))
1177 (cond ((not (types-equal-or-intersect x array
))
1178 '()) ; Definitely not an array!
1180 (let ((dims (array-type-dimensions x
)))
1183 (list (length dims
)))))
1186 ;; Might as well catch some easy negation cases.
1189 (let ((dims (array-type-dimensions x
)))
1190 (cond ((eql dims
'*)
1192 ((every (lambda (dim)
1195 (list (length dims
)))
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
'*)
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
)
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."
1236 (let ((dim (nth axis dims
)))
1237 (cond ((integerp dim
)
1239 ((= (length dims
) 1)
1240 (ecase (conservative-array-type-complexp array-type
)
1242 '(%array-dimension array
0))
1244 '(vector-length array
))
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."))
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
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
))))
1275 (give-up-ir1-transform))
1276 (when (conservative-array-type-complexp vtype
)
1277 (give-up-ir1-transform))
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
))
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
)
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
)
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
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
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
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
)))
1366 `(if (<= 0 ,n-svalue
,n-end
,n-len
)
1367 (values (truly-the simple-array
,n-array
)
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
1381 `(%with-array-data
/fp
,n-array
,n-svalue
,n-evalue
))
1383 `(%with-array-data
,n-array
,n-svalue
,n-evalue
)))))
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
1391 (with-unique-names (size defaulted-end data cumulative-offset
)
1392 `(let* ((,size
,(cond (check-fill-pointer
1393 `(length (the vector
,array
)))
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
)
1407 (%array-data
,data
))
1408 (,cumulative-offset
,(if array-header-p
1409 `(%array-displacement
,array
)
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
1436 `(let* ((data (truly-the (simple-array ,element-type
(*))
1437 (%array-data array
)))
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
)
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
)
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
)
1475 (define-source-transform ,reffer
(a &rest i
)
1476 `(aref (the (,',(if simplep
'simple-array
'array
)
1478 ,(mapcar (constantly '*) i
))
1480 (define-source-transform (setf ,reffer
) (value a
&rest i
)
1481 `(setf (aref (the (,',(if simplep
'simple-array
'array
)
1483 ,(mapcar (constantly '*) i
))
1486 (define-bit-frob sbit t
)
1487 (define-bit-frob bit nil
))
1489 (macrolet ((define-frob (reffer setter type
)
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
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
)
1511 (array-type-declared-element-type (lambda-var-type var
))))))
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
)
1524 (array-type-declared-element-type (lambda-var-type var
))))))
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
)
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
1559 (do* ((dims dims
(cdr dims
))
1560 (indices n-indices
(cdr indices
))
1561 (last-dim nil
(car dims
))
1562 (form `(check-bound ,',array
1574 ((null (cdr dims
)) form
)))))
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
)
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
)))
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
))
1609 `(data-vector-ref array
1610 (check-bound array
(array-dimension array
0) index
))))
1611 (if (type= declared-element-ctype element-ctype
)
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
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.")))
1649 ``(truly-the ,declared-type
1650 (,',transform-to array
1652 (array-dimension array
0)
1654 (the ,declared-type
,@',extra
)))
1655 ``(the ,declared-type
1656 (,',transform-to array
1658 (array-dimension array
0)
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
)
1676 ;;;; bit-vector array operation canonicalization
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
1683 (macrolet ((def (fun)
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
)))))
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
1723 (let ((dims (array-type-dimensions type
)))
1724 (cond ((csubtypep type
(specifier-type '(simple-array * (*))))
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
)))