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
'*)))))
665 (header-form (and complex
666 `(make-array-header ,(or (sb!vm
:saetp-complex-typecode saetp
)
667 sb
!vm
:complex-vector-widetag
) 1)))
669 `(truly-the ,data-result-spec
670 (allocate-vector ,typecode
671 ;; If LENGTH is a singleton list,
672 ;; we want to avoid reading it.
673 (the index
,(or c-length
'length
))
675 (flet ((eliminate-keywords ()
676 (eliminate-keyword-args
678 '((:element-type element-type
)
679 (:initial-contents initial-contents
)
680 (:initial-element initial-element
)
681 (:adjustable adjustable
)
682 (:fill-pointer fill-pointer
))))
683 (with-alloc-form (&optional data-wrapper
)
686 (csubtypep (lvar-type fill-pointer
) (specifier-type 'index
))
687 (not (types-equal-or-intersect (lvar-type fill-pointer
)
688 (specifier-type `(integer 0 ,c-length
)))))
689 (compiler-warn "Invalid fill-pointer ~s for a vector of length ~s."
690 (type-specifier (lvar-type fill-pointer
))
692 (give-up-ir1-transform))
694 (let* ((constant-fill-pointer-p (constant-lvar-p fill-pointer
))
695 (fill-pointer-value (and constant-fill-pointer-p
696 (lvar-value fill-pointer
))))
697 `(let* ((header ,header-form
)
698 (data ,data-alloc-form
)
699 (data ,(or data-wrapper
'data
))
700 (length (the index
,(or c-length
'length
))))
701 (setf (%array-fill-pointer header
)
702 ,(cond ((eq fill-pointer-value t
)
706 (not constant-fill-pointer-p
))
707 `(cond ((or (eq fill-pointer t
)
710 ((> fill-pointer length
)
711 (error "Invalid fill-pointer ~a" fill-pointer
))
716 (setf (%array-fill-pointer-p header
)
718 `(and fill-pointer t
)))
719 (setf (%array-available-elements header
) length
)
720 (setf (%array-data-vector header
) data
)
721 (setf (%array-displaced-p header
) nil
)
722 (setf (%array-displaced-from header
) nil
)
723 (setf (%array-dimension header
0) length
)
724 (truly-the ,result-spec header
))))
726 (subst data-alloc-form
'data data-wrapper
))
729 (cond ((and initial-element initial-contents
)
730 (abort-ir1-transform "Both ~S and ~S specified."
731 :initial-contents
:initial-element
))
733 ;; :INITIAL-CONTENTS (LIST ...), (VECTOR ...) and `(1 1 ,x) with a
735 ((and initial-contents c-length
736 (lvar-matches initial-contents
737 ;; FIXME: probably don't need all 4 of these now?
738 :fun-names
'(list vector
739 sb
!impl
::|List| sb
!impl
::|Vector|
)
740 :arg-count c-length
))
741 (let ((parameters (eliminate-keywords))
742 (elt-vars (make-gensym-list c-length
))
743 (lambda-list '(length)))
744 (splice-fun-args initial-contents
:any c-length
)
745 (dolist (p parameters
)
748 (if (eq p
'initial-contents
)
751 `(lambda ,lambda-list
752 (declare (type ,elt-spec
,@elt-vars
)
753 (ignorable ,@lambda-list
))
755 `(initialize-vector data
,@elt-vars
)))))
757 ;; constant :INITIAL-CONTENTS and LENGTH
758 ((and initial-contents c-length
759 (constant-lvar-p initial-contents
)
760 ;; As a practical matter, the initial-contents should not be
761 ;; too long, otherwise the compiler seems to spend forever
762 ;; compiling the lambda with one parameter per item.
763 ;; To make matters worse, the time grows superlinearly,
764 ;; and it's not entirely obvious that passing a constant array
765 ;; of 100x100 things is responsible for such an explosion.
766 (<= (length (lvar-value initial-contents
)) 1000))
767 (let ((contents (lvar-value initial-contents
)))
768 (unless (= c-length
(length contents
))
769 (abort-ir1-transform "~S has ~S elements, vector length is ~S."
770 :initial-contents
(length contents
) c-length
))
771 (let ((lambda-list `(length ,@(eliminate-keywords))))
772 `(lambda ,lambda-list
773 (declare (ignorable ,@lambda-list
))
775 `(initialize-vector data
776 ,@(map 'list
(lambda (elt)
777 `(the ,elt-spec
',elt
))
780 ;; any other :INITIAL-CONTENTS
782 (let ((lambda-list `(length ,@(eliminate-keywords))))
783 `(lambda ,lambda-list
784 (declare (ignorable ,@lambda-list
))
785 (unless (= (length initial-contents
) ,(or c-length
'length
))
786 (error "~S has ~D elements, vector length is ~D."
787 :initial-contents
(length initial-contents
)
788 ,(or c-length
'length
)))
790 `(replace data initial-contents
)))))
792 ;; :INITIAL-ELEMENT, not EQL to the default
793 ((and initial-element
794 (or (not (constant-lvar-p initial-element
))
795 (not (eql default-initial-element
(lvar-value initial-element
)))))
796 (let ((lambda-list `(length ,@(eliminate-keywords)))
797 (init (if (constant-lvar-p initial-element
)
798 (list 'quote
(lvar-value initial-element
))
800 `(lambda ,lambda-list
801 (declare (ignorable ,@lambda-list
))
803 `(fill data
(the ,elt-spec
,init
))))))
805 ;; just :ELEMENT-TYPE, or maybe with :INITIAL-ELEMENT EQL to the
809 (and (and (testable-type-p elt-ctype
)
810 (neq elt-ctype
*empty-type
*)
811 (not (ctypep default-initial-element elt-ctype
)))
812 ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE
813 ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If
814 ;; INITIAL-ELEMENT is not supplied, the consequences of later
815 ;; reading an uninitialized element of new-array are undefined,"
816 ;; so this could be legal code as long as the user plans to
817 ;; write before he reads, and if he doesn't we're free to do
818 ;; anything we like. But in case the user doesn't know to write
819 ;; elements before he reads elements (or to read manuals before
820 ;; he writes code:-), we'll signal a STYLE-WARNING in case he
821 ;; didn't realize this.
824 (compiler-warn "~S ~S is not a ~S"
825 :initial-element default-initial-element
827 ;; For the default initial element, only warn if
828 ;; any array elements are initialized using it.
829 ((not (eql c-length
0))
830 (compiler-style-warn "The default initial element ~S is not a ~S."
831 default-initial-element
833 (let ((lambda-list `(length ,@(eliminate-keywords))))
834 `(lambda ,lambda-list
835 (declare (ignorable ,@lambda-list
))
836 ,(with-alloc-form))))))))
838 ;;; IMPORTANT: The order of these three MAKE-ARRAY forms matters: the least
839 ;;; specific must come first, otherwise suboptimal transforms will result for
842 (deftransform make-array
((dims &key initial-element initial-contents
844 adjustable fill-pointer
846 displaced-index-offset
)
849 (delay-ir1-transform node
:constraint
)
850 (when (and initial-contents initial-element
)
851 (compiler-warn "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS")
852 (give-up-ir1-transform))
853 (when (and displaced-index-offset
855 (compiler-warn "Can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO")
856 (give-up-ir1-transform))
857 (let ((fp-type (and fill-pointer
858 (lvar-type fill-pointer
)) ))
860 (csubtypep fp-type
(specifier-type '(or index
(eql t
)))))
861 (let* ((dims (and (constant-lvar-p dims
)
863 (length (cond ((integerp dims
)
869 (compiler-warn "Only vectors can have fill pointers."))
870 ((and (csubtypep fp-type
(specifier-type 'index
))
871 (not (types-equal-or-intersect fp-type
872 (specifier-type `(integer 0 ,length
)))))
873 (compiler-warn "Invalid fill-pointer ~s for a vector of length ~s."
874 (type-specifier fp-type
)
876 (macrolet ((maybe-arg (arg)
877 `(and ,arg
`(,,(keywordicate arg
) ,',arg
))))
878 (let* ((eltype (cond ((not element-type
) t
)
879 ((not (constant-lvar-p element-type
))
880 (give-up-ir1-transform
881 "ELEMENT-TYPE is not constant."))
883 (lvar-value element-type
))))
884 (eltype-type (ir1-transform-specifier-type eltype
))
885 (saetp (if (unknown-type-p eltype-type
)
886 (give-up-ir1-transform
887 "ELEMENT-TYPE ~s is not a known type"
890 sb
!vm
:*specialized-array-element-type-properties
*
891 :key
#'sb
!vm
:saetp-ctype
893 (creation-form `(%make-array
896 (sb!vm
:saetp-typecode saetp
)
897 (give-up-ir1-transform))
898 ,(sb!vm
:saetp-n-bits-shift saetp
)
899 ,@(maybe-arg initial-contents
)
900 ,@(maybe-arg adjustable
)
901 ,@(maybe-arg fill-pointer
)
902 ,@(maybe-arg displaced-to
)
903 ,@(maybe-arg displaced-index-offset
))))
904 (cond ((or (not initial-element
)
905 (and (constant-lvar-p initial-element
)
906 (eql (lvar-value initial-element
)
907 (sb!vm
:saetp-initial-element-default saetp
))))
910 ;; error checking for target, disabled on the host because
911 ;; (CTYPE-OF #\Null) is not possible.
913 (when (constant-lvar-p initial-element
)
914 (let ((value (lvar-value initial-element
)))
916 ((not (ctypep value
(sb!vm
:saetp-ctype saetp
)))
917 ;; this case will cause an error at runtime, so we'd
918 ;; better WARN about it now.
919 (warn 'array-initial-element-mismatch
920 :format-control
"~@<~S is not a ~S (which is the ~
925 (type-specifier (sb!vm
:saetp-ctype saetp
))
926 'upgraded-array-element-type
928 ((not (ctypep value eltype-type
))
929 ;; this case will not cause an error at runtime, but
930 ;; it's still worth STYLE-WARNing about.
931 (compiler-style-warn "~S is not a ~S."
933 `(let ((array ,creation-form
))
934 (multiple-value-bind (vector)
935 (%data-vector-and-index array
0)
936 (fill vector
(the ,(sb!vm
:saetp-specifier saetp
) initial-element
)))
939 ;;; The list type restriction does not ensure that the result will be a
940 ;;; multi-dimensional array. But the lack of adjustable, fill-pointer,
941 ;;; and displaced-to keywords ensures that it will be simple.
942 (deftransform make-array
((dims &key
943 element-type initial-element initial-contents
944 adjustable fill-pointer
)
946 (:element-type
(constant-arg *))
948 (:initial-contents
*)
954 ;; If lvar-use of DIMS is a call to LIST, then it must mean that LIST
955 ;; was declared notinline - because if it weren't, then it would have been
956 ;; source-transformed into CONS - which gives us reason NOT to optimize
957 ;; this call to MAKE-ARRAY. So look for CONS instead of LIST,
958 ;; which means that LIST was *not* declared notinline.
959 (when (and (lvar-matches dims
:fun-names
'(cons) :arg-count
2)
960 (let ((cdr (second (combination-args (lvar-uses dims
)))))
961 (and (constant-lvar-p cdr
) (null (lvar-value cdr
)))))
962 (let* ((args (splice-fun-args dims
:any
2)) ; the args to CONS
965 (setf (combination-args call
) (delete dummy
(combination-args call
)))
966 (return-from make-array
967 (transform-make-array-vector (car args
)
972 :adjustable adjustable
973 :fill-pointer fill-pointer
))))
974 (unless (constant-lvar-p dims
)
975 (give-up-ir1-transform
976 "The dimension list is not constant; cannot open code array creation."))
977 (let ((dims (lvar-value dims
))
978 (element-type-ctype (and (constant-lvar-p element-type
)
979 (ir1-transform-specifier-type
980 (lvar-value element-type
)))))
981 (when (contains-unknown-type-p element-type-ctype
)
982 (give-up-ir1-transform))
983 (unless (every (lambda (x) (typep x
'(integer 0))) dims
)
984 (give-up-ir1-transform
985 "The dimension list contains something other than an integer: ~S"
987 (cond ((singleton-p dims
)
988 (transform-make-array-vector (car dims
) element-type
989 initial-element initial-contents call
990 :adjustable adjustable
991 :fill-pointer fill-pointer
))
994 (constant-lvar-p fill-pointer
)
995 (null (lvar-value fill-pointer
)))))
996 (give-up-ir1-transform))
998 (let* ((total-size (reduce #'* dims
))
1000 (complex (cond ((not adjustable
) nil
)
1001 ((not (constant-lvar-p adjustable
))
1002 (give-up-ir1-transform))
1003 ((lvar-value adjustable
))))
1004 (spec `(,(if complex
1007 ,(cond ((null element-type
) t
)
1009 (sb!xc
:upgraded-array-element-type
1010 (lvar-value element-type
)))
1012 ,(make-list rank
:initial-element
'*))))
1013 `(let ((header (make-array-header ,(if complex
1014 sb
!vm
:complex-array-widetag
1015 sb
!vm
:simple-array-widetag
)
1017 (data (make-array ,total-size
1018 ,@(when element-type
1019 '(:element-type element-type
))
1020 ,@(when initial-element
1021 '(:initial-element initial-element
)))))
1022 ,@(when initial-contents
1023 ;; FIXME: This is could be open coded at least a bit too
1024 `((fill-data-vector data
',dims initial-contents
)))
1025 (setf (%array-fill-pointer header
) ,total-size
)
1026 (setf (%array-fill-pointer-p header
) nil
)
1027 (setf (%array-available-elements header
) ,total-size
)
1028 (setf (%array-data-vector header
) data
)
1029 (setf (%array-displaced-p header
) nil
)
1030 (setf (%array-displaced-from header
) nil
)
1032 (mapcar (lambda (dim)
1033 `(setf (%array-dimension header
,(incf axis
))
1036 (truly-the ,spec header
))))))))
1038 (deftransform make-array
((dims &key element-type initial-element initial-contents
1039 adjustable fill-pointer
)
1041 (:element-type
(constant-arg *))
1042 (:initial-element
*)
1043 (:initial-contents
*)
1048 (transform-make-array-vector dims
1053 :adjustable adjustable
1054 :fill-pointer fill-pointer
))
1057 (deftransform adjust-array
((array dims
&key displaced-to displaced-index-offset
)
1059 (:displaced-to array
)
1060 (:displaced-index-offset
*)))
1061 (unless displaced-to
1062 (give-up-ir1-transform))
1064 (when (invalid-array-p array
)
1065 (invalid-array-error array
))
1066 (unless (= 1 (array-rank array
))
1067 (error "The number of dimensions is not equal to the rank of the array"))
1068 (unless (eql (array-element-type array
) (array-element-type displaced-to
))
1069 (error "Can't displace an array of type ~S to another of type ~S"
1070 (array-element-type array
) (array-element-type displaced-to
)))
1071 (let ((displacement (or displaced-index-offset
0)))
1072 (when (< (array-total-size displaced-to
) (+ displacement dims
))
1073 (error "The :DISPLACED-TO array is too small"))
1074 (if (adjustable-array-p array
)
1075 (let ((nfp (when (array-has-fill-pointer-p array
)
1076 (when (> (%array-fill-pointer array
) dims
)
1077 (error "Cannot ADJUST-ARRAY an array to a size smaller than its fill pointer"))
1078 (%array-fill-pointer array
))))
1079 (set-array-header array displaced-to dims nfp
1080 displacement dims t nil
))
1081 (make-array dims
:element-type
(array-element-type array
)
1082 :displaced-to displaced-to
1083 ,@(and displaced-index-offset
1084 '(:displaced-index-offset displacement
)))))))
1086 ;;;; miscellaneous properties of arrays
1088 ;;; Transforms for various array properties. If the property is know
1089 ;;; at compile time because of a type spec, use that constant value.
1091 ;;; Most of this logic may end up belonging in code/late-type.lisp;
1092 ;;; however, here we also need the -OR-GIVE-UP for the transforms, and
1093 ;;; maybe this is just too sloppy for actual type logic. -- CSR,
1095 (defun array-type-dimensions-or-give-up (type)
1096 (labels ((maybe-array-type-dimensions (type)
1099 (array-type-dimensions type
))
1101 (let* ((types (loop for type in
(union-type-types type
)
1102 for dimensions
= (maybe-array-type-dimensions type
)
1103 when
(eq dimensions
'*)
1105 (return-from maybe-array-type-dimensions
'*)
1108 (result (car types
))
1109 (length (length result
))
1111 (dolist (other (cdr types
))
1112 (when (/= length
(length other
))
1113 (give-up-ir1-transform
1114 "~@<dimensions of arrays in union type ~S do not match~:@>"
1115 (type-specifier type
)))
1116 (unless (equal result other
)
1117 (setf complete-match nil
)))
1120 (make-list length
:initial-element
'*))))
1122 (let* ((types (remove nil
(mapcar #'maybe-array-type-dimensions
1123 (intersection-type-types type
))))
1124 (result (car types
)))
1125 (dolist (other (cdr types
) result
)
1126 (unless (equal result other
)
1127 (abort-ir1-transform
1128 "~@<dimensions of arrays in intersection type ~S do not match~:@>"
1129 (type-specifier type
)))))))))
1130 (or (maybe-array-type-dimensions type
)
1131 (give-up-ir1-transform
1132 "~@<don't know how to extract array dimensions from type ~S~:@>"
1133 (type-specifier type
)))))
1135 (defun conservative-array-type-complexp (type)
1137 (array-type (array-type-complexp type
))
1139 (let ((types (union-type-types type
)))
1140 (aver (> (length types
) 1))
1141 (let ((result (conservative-array-type-complexp (car types
))))
1142 (dolist (type (cdr types
) result
)
1143 (unless (eq (conservative-array-type-complexp type
) result
)
1144 (return-from conservative-array-type-complexp
:maybe
))))))
1145 ;; FIXME: intersection type
1148 ;; Let type derivation handle constant cases. We only do easy strength
1150 (deftransform array-rank
((array) (array) * :node node
)
1151 (let ((array-type (lvar-type array
)))
1152 (cond ((eq t
(and (array-type-p array-type
)
1153 (array-type-complexp array-type
)))
1154 '(%array-rank array
))
1156 (delay-ir1-transform node
:constraint
)
1157 `(if (array-header-p array
)
1161 (defun derive-array-rank (ctype)
1162 (let ((array (specifier-type 'array
)))
1164 (cond ((not (types-equal-or-intersect x array
))
1165 '()) ; Definitely not an array!
1167 (let ((dims (array-type-dimensions x
)))
1170 (list (length dims
)))))
1173 ;; Might as well catch some easy negation cases.
1176 (let ((dims (array-type-dimensions x
)))
1177 (cond ((eql dims
'*)
1179 ((every (lambda (dim)
1182 (list (length dims
)))
1186 (declare (dynamic-extent #'over
#'under
))
1187 (multiple-value-bind (not-p ranks
)
1188 (list-abstract-type-function ctype
#'over
:under
#'under
)
1189 (cond ((eql ranks
'*)
1193 (specifier-type `(not (member ,@ranks
))))
1195 (specifier-type `(member ,@ranks
))))))))
1197 (defoptimizer (array-rank derive-type
) ((array))
1198 (derive-array-rank (lvar-type array
)))
1200 (defoptimizer (%array-rank derive-type
) ((array))
1201 (derive-array-rank (lvar-type array
)))
1203 ;;; If we know the dimensions at compile time, just use it. Otherwise,
1204 ;;; if we can tell that the axis is in bounds, convert to
1205 ;;; %ARRAY-DIMENSION (which just indirects the array header) or length
1206 ;;; (if it's simple and a vector).
1207 (deftransform array-dimension
((array axis
)
1209 (unless (constant-lvar-p axis
)
1210 (give-up-ir1-transform "The axis is not constant."))
1211 ;; Dimensions may change thanks to ADJUST-ARRAY, so we need the
1212 ;; conservative type.
1213 (let ((array-type (lvar-conservative-type array
))
1214 (axis (lvar-value axis
)))
1215 (let ((dims (array-type-dimensions-or-give-up array-type
)))
1216 (unless (listp dims
)
1217 (give-up-ir1-transform
1218 "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime."))
1219 (unless (> (length dims
) axis
)
1220 (abort-ir1-transform "The array has dimensions ~S, ~W is too large."
1223 (let ((dim (nth axis dims
)))
1224 (cond ((integerp dim
)
1226 ((= (length dims
) 1)
1227 (ecase (conservative-array-type-complexp array-type
)
1229 '(%array-dimension array
0))
1231 '(vector-length array
))
1233 `(if (array-header-p array
)
1234 (%array-dimension array axis
)
1235 (vector-length array
)))))
1237 '(%array-dimension array axis
)))))))
1239 ;;; If the length has been declared and it's simple, just return it.
1240 (deftransform length
((vector)
1241 ((simple-array * (*))))
1242 (let ((type (lvar-type vector
)))
1243 (let ((dims (array-type-dimensions-or-give-up type
)))
1244 (unless (and (listp dims
) (integerp (car dims
)))
1245 (give-up-ir1-transform
1246 "Vector length is unknown, must call LENGTH at runtime."))
1249 ;;; All vectors can get their length by using VECTOR-LENGTH. If it's
1250 ;;; simple, it will extract the length slot from the vector. It it's
1251 ;;; complex, it will extract the fill pointer slot from the array
1253 (deftransform length
((vector) (vector))
1254 '(vector-length vector
))
1256 ;;; If a simple array with known dimensions, then VECTOR-LENGTH is a
1257 ;;; compile-time constant.
1258 (deftransform vector-length
((vector))
1259 (let ((vtype (lvar-type vector
)))
1260 (let ((dim (first (array-type-dimensions-or-give-up vtype
))))
1262 (give-up-ir1-transform))
1263 (when (conservative-array-type-complexp vtype
)
1264 (give-up-ir1-transform))
1267 ;;; Again, if we can tell the results from the type, just use it.
1268 ;;; Otherwise, if we know the rank, convert into a computation based
1269 ;;; on array-dimension or %array-available-elements
1270 (deftransform array-total-size
((array) (array))
1271 (let* ((array-type (lvar-type array
))
1272 (dims (array-type-dimensions-or-give-up array-type
)))
1273 (unless (listp dims
)
1274 (give-up-ir1-transform "can't tell the rank at compile time"))
1275 (cond ((not (memq '* dims
))
1278 ;; A vector, can't use LENGTH since this ignores the fill-pointer
1279 `(truly-the index
(array-dimension array
0)))
1281 `(%array-available-elements array
)))))
1283 ;;; Only complex vectors have fill pointers.
1284 (deftransform array-has-fill-pointer-p
((array))
1285 (let ((array-type (lvar-type array
)))
1286 (let ((dims (array-type-dimensions-or-give-up array-type
)))
1287 (if (and (listp dims
) (not (= (length dims
) 1)))
1289 (ecase (conservative-array-type-complexp array-type
)
1295 (give-up-ir1-transform
1296 "The array type is ambiguous; must call ~
1297 ARRAY-HAS-FILL-POINTER-P at runtime.")))))))
1299 (deftransform check-bound
((array dimension index
) * * :node node
)
1300 ;; This is simply to avoid multiple evaluation of INDEX by the
1301 ;; translator, it's easier to wrap it in a lambda from DEFTRANSFORM
1302 `(bound-cast array
,(if (constant-lvar-p dimension
)
1303 (lvar-value dimension
)
1307 ;;;; WITH-ARRAY-DATA
1309 ;;; This checks to see whether the array is simple and the start and
1310 ;;; end are in bounds. If so, it proceeds with those values.
1311 ;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that %WITH-ARRAY-DATA
1312 ;;; may be further optimized.
1314 ;;; Given any ARRAY, bind DATA-VAR to the array's data vector and
1315 ;;; START-VAR and END-VAR to the start and end of the designated
1316 ;;; portion of the data vector. SVALUE and EVALUE are any start and
1317 ;;; end specified to the original operation, and are factored into the
1318 ;;; bindings of START-VAR and END-VAR. OFFSET-VAR is the cumulative
1319 ;;; offset of all displacements encountered, and does not include
1322 ;;; When FORCE-INLINE is set, the underlying %WITH-ARRAY-DATA form is
1323 ;;; forced to be inline, overriding the ordinary judgment of the
1324 ;;; %WITH-ARRAY-DATA DEFTRANSFORMs. Ordinarily the DEFTRANSFORMs are
1325 ;;; fairly picky about their arguments, figuring that if you haven't
1326 ;;; bothered to get all your ducks in a row, you probably don't care
1327 ;;; that much about speed anyway! But in some cases it makes sense to
1328 ;;; do type testing inside %WITH-ARRAY-DATA instead of outside, and
1329 ;;; the DEFTRANSFORM can't tell that that's going on, so it can make
1330 ;;; sense to use FORCE-INLINE option in that case.
1331 (sb!xc
:defmacro with-array-data
(((data-var array
&key offset-var
)
1332 (start-var &optional
(svalue 0))
1333 (end-var &optional
(evalue nil
))
1334 &key force-inline check-fill-pointer
1338 (once-only ((n-array array
)
1339 (n-svalue `(the index
,svalue
))
1340 (n-evalue `(the (or index null
) ,evalue
)))
1341 (let ((check-bounds (policy env
(plusp insert-array-bounds-checks
))))
1342 `(multiple-value-bind (,data-var
1345 ,@ (when offset-var
`(,offset-var
)))
1346 (cond ,@(and (not array-header-p
)
1347 `(((not (array-header-p ,n-array
))
1348 (let ((,n-array
,n-array
))
1349 (declare (type vector
,n-array
))
1350 ,(once-only ((n-len `(length ,n-array
))
1351 (n-end `(or ,n-evalue
,n-len
)))
1353 `(if (<= 0 ,n-svalue
,n-end
,n-len
)
1354 (values (truly-the simple-array
,n-array
)
1356 ,(if check-fill-pointer
1357 `(sequence-bounding-indices-bad-error ,n-array
,n-svalue
,n-evalue
)
1358 `(array-bounding-indices-bad-error ,n-array
,n-svalue
,n-evalue
)))
1359 `(values (truly-the simple-array
,n-array
)
1360 ,n-svalue
,n-end
0)))))))
1362 ,(cond (force-inline
1363 `(%with-array-data-macro
,n-array
,n-svalue
,n-evalue
1364 :check-bounds
,check-bounds
1365 :check-fill-pointer
,check-fill-pointer
1368 `(%with-array-data
/fp
,n-array
,n-svalue
,n-evalue
))
1370 `(%with-array-data
,n-array
,n-svalue
,n-evalue
)))))
1373 ;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in
1374 ;;; DEFTRANSFORMs and DEFUNs.
1375 (sb!xc
:defmacro %with-array-data-macro
1376 (array start end
&key
(element-type '*) check-bounds check-fill-pointer
1378 (with-unique-names (size defaulted-end data cumulative-offset
)
1379 `(let* ((,size
,(cond (check-fill-pointer
1380 `(length (the vector
,array
)))
1382 `(%array-available-elements
,array
))
1384 `(array-total-size ,array
))))
1385 (,defaulted-end
(or ,end
,size
)))
1386 ,@ (when check-bounds
1387 `((unless (<= ,start
,defaulted-end
,size
)
1388 ,(if check-fill-pointer
1389 `(sequence-bounding-indices-bad-error ,array
,start
,end
)
1390 `(array-bounding-indices-bad-error ,array
,start
,end
)))))
1391 (do ((,data
,(if array-header-p
1392 `(%array-data-vector
,array
)
1394 (%array-data-vector
,data
))
1395 (,cumulative-offset
,(if array-header-p
1396 `(%array-displacement
,array
)
1399 (+ ,cumulative-offset
1400 (%array-displacement
,data
)))))
1401 ((not (array-header-p ,data
))
1402 (values (truly-the (simple-array ,element-type
1) ,data
)
1403 (truly-the index
(+ ,cumulative-offset
,start
))
1404 (truly-the index
(+ ,cumulative-offset
,defaulted-end
))
1405 ,cumulative-offset
))))))
1407 (defun transform-%with-array-data
/mumble
(array node check-fill-pointer
)
1408 (let ((element-type (upgraded-element-type-specifier-or-give-up array
))
1409 (type (lvar-type array
))
1410 (check-bounds (policy node
(plusp insert-array-bounds-checks
))))
1411 (if (and (array-type-p type
)
1412 (not (array-type-complexp type
))
1413 (listp (array-type-dimensions type
))
1414 (not (null (cdr (array-type-dimensions type
)))))
1415 ;; If it's a simple multidimensional array, then just return
1416 ;; its data vector directly rather than going through
1417 ;; %WITH-ARRAY-DATA-MACRO. SBCL doesn't generally generate
1418 ;; code that would use this currently, but we have encouraged
1419 ;; users to use WITH-ARRAY-DATA and we may use it ourselves at
1420 ;; some point in the future for optimized libraries or
1423 `(let* ((data (truly-the (simple-array ,element-type
(*))
1424 (%array-data-vector array
)))
1426 (real-end (or end len
)))
1427 (unless (<= 0 start data-end lend
)
1428 (sequence-bounding-indices-bad-error array start end
))
1429 (values data
0 real-end
0))
1430 `(let ((data (truly-the (simple-array ,element-type
(*))
1431 (%array-data-vector array
))))
1432 (values data
0 (or end
(length data
)) 0)))
1433 `(%with-array-data-macro array start end
1434 :check-fill-pointer
,check-fill-pointer
1435 :check-bounds
,check-bounds
1436 :element-type
,element-type
))))
1438 ;; It might very well be reasonable to allow general ARRAY here, I
1439 ;; just haven't tried to understand the performance issues involved.
1440 ;; -- WHN, and also CSR 2002-05-26
1441 (deftransform %with-array-data
((array start end
)
1442 ((or vector simple-array
) index
(or index null
) t
)
1445 :policy
(> speed space
))
1446 "inline non-SIMPLE-vector-handling logic"
1447 (transform-%with-array-data
/mumble array node nil
))
1448 (deftransform %with-array-data
/fp
((array start end
)
1449 ((or vector simple-array
) index
(or index null
) t
)
1452 :policy
(> speed space
))
1453 "inline non-SIMPLE-vector-handling logic"
1454 (transform-%with-array-data
/mumble array node t
))
1456 ;;;; array accessors
1458 ;;; We convert all typed array accessors into AREF and (SETF AREF) with type
1459 ;;; assertions on the array.
1460 (macrolet ((define-bit-frob (reffer simplep
)
1462 (define-source-transform ,reffer
(a &rest i
)
1463 `(aref (the (,',(if simplep
'simple-array
'array
)
1465 ,(mapcar (constantly '*) i
))
1467 (define-source-transform (setf ,reffer
) (value a
&rest i
)
1468 `(setf (aref (the (,',(if simplep
'simple-array
'array
)
1470 ,(mapcar (constantly '*) i
))
1473 (define-bit-frob sbit t
)
1474 (define-bit-frob bit nil
))
1476 (macrolet ((define-frob (reffer setter type
)
1478 (define-source-transform ,reffer
(a i
)
1479 `(aref (the ,',type
,a
) ,i
))
1480 (define-source-transform ,setter
(a i v
)
1481 `(setf (aref (the ,',type
,a
) ,i
) ,v
)))))
1482 (define-frob schar %scharset simple-string
)
1483 (define-frob char %charset string
))
1485 ;;; We transform SVREF and %SVSET directly into DATA-VECTOR-REF/SET: this is
1486 ;;; around 100 times faster than going through the general-purpose AREF
1487 ;;; transform which ends up doing a lot of work -- and introducing many
1488 ;;; intermediate lambdas, each meaning a new trip through the compiler -- to
1489 ;;; get the same result.
1491 ;;; FIXME: [S]CHAR, and [S]BIT above would almost certainly benefit from a similar
1493 (define-source-transform svref
(vector index
)
1494 (let ((elt-type (or (when (symbolp vector
)
1495 (let ((var (lexenv-find vector vars
)))
1496 (when (lambda-var-p var
)
1498 (array-type-declared-element-type (lambda-var-type var
))))))
1500 (with-unique-names (n-vector)
1501 `(let ((,n-vector
,vector
))
1502 (the ,elt-type
(data-vector-ref
1503 (the simple-vector
,n-vector
)
1504 (check-bound ,n-vector
(length ,n-vector
) ,index
)))))))
1506 (define-source-transform %svset
(vector index value
)
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 (truly-the ,elt-type
(data-vector-set
1516 (the simple-vector
,n-vector
)
1517 (check-bound ,n-vector
(length ,n-vector
) ,index
)
1518 (the ,elt-type
,value
)))))))
1520 (macrolet (;; This is a handy macro for computing the row-major index
1521 ;; given a set of indices. We wrap each index with a call
1522 ;; to CHECK-BOUND to ensure that everything works out
1523 ;; correctly. We can wrap all the interior arithmetic with
1524 ;; TRULY-THE INDEX because we know the resultant
1525 ;; row-major index must be an index.
1526 (with-row-major-index ((array indices index
&optional new-value
)
1528 `(let (n-indices dims
)
1529 (dotimes (i (length ,indices
))
1530 (push (make-symbol (format nil
"INDEX-~D" i
)) n-indices
)
1531 (push (make-symbol (format nil
"DIM-~D" i
)) dims
))
1532 (setf n-indices
(nreverse n-indices
))
1533 (setf dims
(nreverse dims
))
1534 `(lambda (,@',(when new-value
(list new-value
))
1535 ,',array
,@n-indices
)
1536 (declare (ignorable ,',array
))
1537 (let* (,@(let ((,index -
1))
1538 (mapcar (lambda (name)
1539 `(,name
(array-dimension
1546 (do* ((dims dims
(cdr dims
))
1547 (indices n-indices
(cdr indices
))
1548 (last-dim nil
(car dims
))
1549 (form `(check-bound ,',array
1561 ((null (cdr dims
)) form
)))))
1564 ;; Just return the index after computing it.
1565 (deftransform array-row-major-index
((array &rest indices
))
1566 (with-row-major-index (array indices index
)
1569 ;; Convert AREF and (SETF AREF) into a HAIRY-DATA-VECTOR-REF (or
1570 ;; HAIRY-DATA-VECTOR-SET) with the set of indices replaced with the an
1571 ;; expression for the row major index.
1572 (deftransform aref
((array &rest indices
))
1573 (with-row-major-index (array indices index
)
1574 (hairy-data-vector-ref array index
)))
1576 (deftransform (setf aref
) ((new-value array
&rest subscripts
))
1577 (with-row-major-index (array subscripts index new-value
)
1578 (hairy-data-vector-set array index new-value
))))
1580 ;; For AREF of vectors we do the bounds checking in the callee. This
1581 ;; lets us do a significantly more efficient check for simple-arrays
1582 ;; without bloating the code. If we already know the type of the array
1583 ;; with sufficient precision, skip directly to DATA-VECTOR-REF.
1584 (deftransform aref
((array index
) (t t
) * :node node
)
1585 (let* ((type (lvar-type array
))
1586 (element-ctype (array-type-upgraded-element-type type
)))
1588 ((eq element-ctype
*empty-type
*)
1589 `(data-nil-vector-ref array index
))
1590 ((and (array-type-p type
)
1591 (null (array-type-complexp type
))
1592 (neq element-ctype
*wild-type
*)
1593 (eql (length (array-type-dimensions type
)) 1))
1594 (let* ((declared-element-ctype (array-type-declared-element-type type
))
1596 `(data-vector-ref array
1597 (check-bound array
(array-dimension array
0) index
))))
1598 (if (type= declared-element-ctype element-ctype
)
1600 `(the ,(type-specifier declared-element-ctype
) ,bare-form
))))
1601 ((policy node
(zerop insert-array-bounds-checks
))
1602 `(hairy-data-vector-ref array index
))
1603 (t `(hairy-data-vector-ref/check-bounds array index
)))))
1605 (deftransform (setf aref
) ((new-value array index
) (t t t
) * :node node
)
1606 (if (policy node
(zerop insert-array-bounds-checks
))
1607 `(hairy-data-vector-set array index new-value
)
1608 `(hairy-data-vector-set/check-bounds array index new-value
)))
1610 ;;; But if we find out later that there's some useful type information
1611 ;;; available, switch back to the normal one to give other transforms
1613 (macrolet ((define (name transform-to extra extra-type
)
1614 (declare (ignore extra-type
))
1615 `(deftransform ,name
((array index
,@extra
))
1616 (let* ((type (lvar-type array
))
1617 (element-type (array-type-upgraded-element-type type
))
1618 (declared-type (type-specifier
1619 (array-type-declared-element-type type
))))
1620 ;; If an element type has been declared, we want to
1621 ;; use that information it for type checking (even
1622 ;; if the access can't be optimized due to the array
1623 ;; not being simple).
1624 (when (and (eq element-type
*wild-type
*)
1625 ;; This type logic corresponds to the special
1626 ;; case for strings in HAIRY-DATA-VECTOR-REF
1627 ;; (generic/vm-tran.lisp)
1628 (not (csubtypep type
(specifier-type 'simple-string
))))
1629 (when (or (not (array-type-p type
))
1630 ;; If it's a simple array, we might be able
1631 ;; to inline the access completely.
1632 (not (null (array-type-complexp type
))))
1633 (give-up-ir1-transform
1634 "Upgraded element type of array is not known at compile time.")))
1636 ``(truly-the ,declared-type
1637 (,',transform-to array
1639 (array-dimension array
0)
1641 (the ,declared-type
,@',extra
)))
1642 ``(the ,declared-type
1643 (,',transform-to array
1645 (array-dimension array
0)
1647 (define hairy-data-vector-ref
/check-bounds
1648 hairy-data-vector-ref nil nil
)
1649 (define hairy-data-vector-set
/check-bounds
1650 hairy-data-vector-set
(new-value) (*)))
1652 ;;; Just convert into a HAIRY-DATA-VECTOR-REF (or
1653 ;;; HAIRY-DATA-VECTOR-SET) after checking that the index is inside the
1654 ;;; array total size.
1655 (deftransform row-major-aref
((array index
))
1656 `(hairy-data-vector-ref array
1657 (check-bound array
(array-total-size array
) index
)))
1658 (deftransform %set-row-major-aref
((array index new-value
))
1659 `(hairy-data-vector-set array
1660 (check-bound array
(array-total-size array
) index
)
1663 ;;;; bit-vector array operation canonicalization
1665 ;;;; We convert all bit-vector operations to have the result array
1666 ;;;; specified. This allows any result allocation to be open-coded,
1667 ;;;; and eliminates the need for any VM-dependent transforms to handle
1670 (macrolet ((def (fun)
1672 (deftransform ,fun
((bit-array-1 bit-array-2
1673 &optional result-bit-array
)
1674 (bit-vector bit-vector
&optional null
) *
1675 :policy
(>= speed space
))
1676 `(,',fun bit-array-1 bit-array-2
1677 (make-array (array-dimension bit-array-1
0) :element-type
'bit
)))
1678 ;; If result is T, make it the first arg.
1679 (deftransform ,fun
((bit-array-1 bit-array-2 result-bit-array
)
1680 (bit-vector bit-vector
(eql t
)) *)
1681 `(,',fun bit-array-1 bit-array-2 bit-array-1
)))))
1693 ;;; Similar for BIT-NOT, but there is only one arg...
1694 (deftransform bit-not
((bit-array-1 &optional result-bit-array
)
1695 (bit-vector &optional null
) *
1696 :policy
(>= speed space
))
1697 '(bit-not bit-array-1
1698 (make-array (array-dimension bit-array-1
0) :element-type
'bit
)))
1699 (deftransform bit-not
((bit-array-1 result-bit-array
)
1700 (bit-vector (eql t
)))
1701 '(bit-not bit-array-1 bit-array-1
))
1703 ;;; Pick off some constant cases.
1704 (defoptimizer (array-header-p derive-type
) ((array))
1705 (let ((type (lvar-type array
)))
1706 (cond ((not (array-type-p type
))
1707 ;; FIXME: use analogue of ARRAY-TYPE-DIMENSIONS-OR-GIVE-UP
1710 (let ((dims (array-type-dimensions type
)))
1711 (cond ((csubtypep type
(specifier-type '(simple-array * (*))))
1713 (specifier-type 'null
))
1714 ((and (listp dims
) (/= (length dims
) 1))
1715 ;; multi-dimensional array, will have a header
1716 (specifier-type '(eql t
)))
1717 ((eql (array-type-complexp type
) t
)
1718 (specifier-type '(eql t
)))
