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
))))))
127 (lvar-type new-value
))
129 ;;; Return true if ARG is NIL, or is a constant-lvar whose
130 ;;; value is NIL, false otherwise.
131 (defun unsupplied-or-nil (arg)
132 (declare (type (or lvar null
) arg
))
134 (and (constant-lvar-p arg
)
135 (not (lvar-value arg
)))))
137 (defun supplied-and-true (arg)
139 (constant-lvar-p arg
)
143 ;;;; DERIVE-TYPE optimizers
145 ;;; Array operations that use a specific number of indices implicitly
146 ;;; assert that the array is of that rank.
147 (defun assert-array-rank (array rank
)
150 (specifier-type `(array * ,(make-list rank
:initial-element
'*)))
151 (lexenv-policy (node-lexenv (lvar-dest array
)))))
153 (defun derive-aref-type (array)
154 (multiple-value-bind (uaet other
)
155 (array-type-upgraded-element-type (lvar-type array
))
158 (defoptimizer (array-in-bounds-p derive-type
) ((array &rest indices
))
159 (assert-array-rank array
(length indices
))
162 (deftransform array-in-bounds-p
((array &rest subscripts
))
164 (flet ((give-up (&optional reason
)
165 (cond ((= (length subscripts
) 1)
166 (let ((arg (sb!xc
:gensym
)))
167 `(lambda (array ,arg
)
168 (< ,arg
(array-dimension array
0)))))
170 (give-up-ir1-transform
172 "~@<lower array bounds unknown or negative and upper bounds not ~
175 (integerp x
))) ; might be NIL or *
176 (let ((dimensions (catch-give-up-ir1-transform
177 ((array-type-dimensions-or-give-up
178 (lvar-conservative-type array
))
180 (give-up (car args
)))))
181 ;; Might be *. (Note: currently this is never true, because the type
182 ;; derivation infers the rank from the call to ARRAY-IN-BOUNDS-P, but
183 ;; let's keep this future proof.)
184 (when (eq '* dimensions
)
185 (give-up "array bounds unknown"))
186 ;; shortcut for zero dimensions
187 (when (some (lambda (dim)
188 (and (bound-known-p dim
) (zerop dim
)))
191 ;; we first collect the subscripts LVARs' bounds and see whether
192 ;; we can already decide on the result of the optimization without
193 ;; even taking a look at the dimensions.
194 (flet ((subscript-bounds (subscript)
195 (let* ((type1 (lvar-type subscript
))
196 (type2 (if (csubtypep type1
(specifier-type 'integer
))
197 (weaken-integer-type type1
:range-only t
)
199 (low (if (integer-type-p type2
)
200 (numeric-type-low type2
)
202 (high (numeric-type-high type2
)))
204 ((and (or (not (bound-known-p low
)) (minusp low
))
205 (or (not (bound-known-p high
)) (not (minusp high
))))
206 ;; can't be sure about the lower bound and the upper bound
207 ;; does not give us a definite clue either.
209 ((and (bound-known-p high
) (minusp high
))
210 (return nil
)) ; definitely below lower bound (zero).
213 (let* ((subscripts-bounds (mapcar #'subscript-bounds subscripts
))
214 (subscripts-lower-bound (mapcar #'car subscripts-bounds
))
215 (subscripts-upper-bound (mapcar #'cdr subscripts-bounds
))
217 (mapcar (lambda (low high dim
)
219 ;; first deal with infinite bounds
220 ((some (complement #'bound-known-p
) (list low high dim
))
221 (when (and (bound-known-p dim
) (bound-known-p low
) (<= dim low
))
223 ;; now we know all bounds
227 (aver (not (minusp low
)))
231 subscripts-lower-bound
232 subscripts-upper-bound
234 (if (eql in-bounds
(length dimensions
))
238 (defoptimizer (aref derive-type
) ((array &rest indices
))
239 (assert-array-rank array
(length indices
))
240 (derive-aref-type array
))
242 (defoptimizer ((setf aref
) derive-type
) ((new-value array
&rest subscripts
))
243 (assert-array-rank array
(length subscripts
))
244 (assert-new-value-type new-value array
))
246 (macrolet ((define (name)
247 `(defoptimizer (,name derive-type
) ((array index
))
248 (declare (ignore index
))
249 (derive-aref-type array
))))
250 (define hairy-data-vector-ref
)
251 (define hairy-data-vector-ref
/check-bounds
)
252 (define data-vector-ref
))
255 (defoptimizer (data-vector-ref-with-offset derive-type
) ((array index offset
))
256 (declare (ignore index offset
))
257 (derive-aref-type array
))
259 (macrolet ((define (name)
260 `(defoptimizer (,name derive-type
) ((array index new-value
))
261 (declare (ignore index
))
262 (assert-new-value-type new-value array
))))
263 (define hairy-data-vector-set
)
264 (define hairy-data-vector-set
/check-bounds
)
265 (define data-vector-set
))
268 (defoptimizer (data-vector-set-with-offset derive-type
) ((array index offset new-value
))
269 (declare (ignore index offset
))
270 (assert-new-value-type new-value array
))
272 ;;; Figure out the type of the data vector if we know the argument
274 (defun derive-%with-array-data
/mumble-type
(array)
275 (let ((atype (lvar-type array
)))
276 (when (array-type-p atype
)
278 `(simple-array ,(type-specifier
279 (array-type-specialized-element-type atype
))
281 (defoptimizer (%with-array-data derive-type
) ((array start end
))
282 (declare (ignore start end
))
283 (derive-%with-array-data
/mumble-type array
))
284 (defoptimizer (%with-array-data
/fp derive-type
) ((array start end
))
285 (declare (ignore start end
))
286 (derive-%with-array-data
/mumble-type array
))
288 (defoptimizer (array-row-major-index derive-type
) ((array &rest indices
))
289 (assert-array-rank array
(length indices
))
292 (defoptimizer (row-major-aref derive-type
) ((array index
))
293 (declare (ignore index
))
294 (derive-aref-type array
))
296 (defoptimizer (%set-row-major-aref derive-type
) ((array index new-value
))
297 (declare (ignore index
))
298 (assert-new-value-type new-value array
))
300 (defun derive-make-array-type (dims element-type adjustable
301 fill-pointer displaced-to
)
302 (let* ((simple (and (unsupplied-or-nil adjustable
)
303 (unsupplied-or-nil displaced-to
)
304 (unsupplied-or-nil fill-pointer
)))
306 (or `(,(if simple
'simple-array
'array
)
307 ,(cond ((not element-type
) t
)
308 ((ctype-p element-type
)
309 (type-specifier element-type
))
310 ((constant-lvar-p element-type
)
311 (let ((ctype (careful-specifier-type
312 (lvar-value element-type
))))
314 ((or (null ctype
) (contains-unknown-type-p ctype
)) '*)
315 (t (sb!xc
:upgraded-array-element-type
316 (lvar-value element-type
))))))
319 ,(cond ((constant-lvar-p dims
)
320 (let* ((val (lvar-value dims
))
321 (cdims (if (listp val
) val
(list val
))))
325 ((csubtypep (lvar-type dims
)
326 (specifier-type 'integer
))
331 (if (and (not simple
)
332 (or (supplied-and-true adjustable
)
333 (supplied-and-true displaced-to
)
334 (supplied-and-true fill-pointer
)))
335 (careful-specifier-type `(and ,spec
(not simple-array
)))
336 (careful-specifier-type spec
))))
338 (defoptimizer (make-array derive-type
)
339 ((dims &key element-type adjustable fill-pointer displaced-to
))
340 (derive-make-array-type dims element-type adjustable
341 fill-pointer displaced-to
))
343 (defoptimizer (%make-array derive-type
)
344 ((dims widetag n-bits
&key adjustable fill-pointer displaced-to
))
345 (declare (ignore n-bits
))
346 (let ((saetp (and (constant-lvar-p widetag
)
347 (find (lvar-value widetag
)
348 sb
!vm
:*specialized-array-element-type-properties
*
349 :key
#'sb
!vm
:saetp-typecode
))))
350 (derive-make-array-type dims
(if saetp
351 (sb!vm
:saetp-ctype saetp
)
353 adjustable fill-pointer displaced-to
)))
358 ;;; Convert VECTOR into a MAKE-ARRAY.
359 (define-source-transform vector
(&rest elements
)
360 `(make-array ,(length elements
) :initial-contents
(list ,@elements
)))
362 ;;; Just convert it into a MAKE-ARRAY.
363 (deftransform make-string
((length &key
364 (element-type 'character
)
366 #.
*default-init-char-form
*)))
367 `(the simple-string
(make-array (the index length
)
368 :element-type element-type
369 ,@(when initial-element
370 '(:initial-element initial-element
)))))
372 ;; Traverse the :INTIAL-CONTENTS argument to an array constructor call,
373 ;; changing the skeleton of the data to be constructed by calls to LIST
374 ;; and wrapping some declarations around each array cell's constructor.
375 ;; If a macro is involved, expand it before traversing.
377 ;; - Despite the effort to handle multidimensional arrays here,
378 ;; an array-header will not be stack-allocated, so the data won't be either.
379 ;; - inline functions whose behavior is merely to call LIST don't work
380 ;; e.g. :INITIAL-CONTENTS (MY-LIST a b) ; where MY-LIST is inline
381 ;; ; and effectively just (LIST ...)
382 (defun rewrite-initial-contents (rank initial-contents env
)
383 (named-let recurse
((rank rank
) (data initial-contents
))
384 (declare (type index rank
))
386 (flet ((sequence-constructor-p (form)
387 (member (car form
) '(sb!impl
::|List| list
388 sb
!impl
::|Vector| vector
))))
390 (cond ((not (listp data
)) data
)
391 ((sequence-constructor-p data
)
392 `(list ,@(mapcar (lambda (dim) (recurse (1- rank
) dim
))
394 ((and (sb!xc
:macro-function
(car data
) env
)
395 (listp (setq expanded
(sb!xc
:macroexpand data env
)))
396 (sequence-constructor-p expanded
))
397 (recurse rank expanded
))
399 ;; This is the important bit: once we are past the level of
400 ;; :INITIAL-CONTENTS that relates to the array structure, reinline LIST
401 ;; and VECTOR so that nested DX isn't screwed up.
402 `(locally (declare (inline list vector
)) ,data
))))
404 ;;; Prevent open coding DIMENSION and :INITIAL-CONTENTS arguments, so that we
405 ;;; can pick them apart in the DEFTRANSFORMS, and transform '(3) style
406 ;;; dimensions to integer args directly.
407 (define-source-transform make-array
(dimensions &rest keyargs
&environment env
)
408 (if (or (and (fun-lexically-notinline-p 'list
)
409 (fun-lexically-notinline-p 'vector
))
410 (oddp (length keyargs
)))
412 (multiple-value-bind (new-dimensions rank
)
413 (flet ((constant-dims (dimensions)
414 (let* ((dims (constant-form-value dimensions env
))
415 (canon (if (listp dims
) dims
(list dims
)))
416 (rank (length canon
)))
417 (values (if (= rank
1)
418 (list 'quote
(car canon
))
421 (cond ((sb!xc
:constantp dimensions env
)
422 (constant-dims dimensions
))
423 ((and (consp dimensions
) (eq 'list dimensions
))
424 (values dimensions
(length (cdr dimensions
))))
426 (values dimensions nil
))))
427 (let ((initial-contents (getf keyargs
:initial-contents
)))
428 (when (and initial-contents rank
)
429 (setf keyargs
(copy-list keyargs
)
430 (getf keyargs
:initial-contents
)
431 (rewrite-initial-contents rank initial-contents env
))))
432 `(locally (declare (notinline list vector
))
433 (make-array ,new-dimensions
,@keyargs
)))))
435 (define-source-transform coerce
(x type
&environment env
)
436 (if (and (sb!xc
:constantp type env
)
438 (memq (car x
) '(sb!impl
::|List| list
439 sb
!impl
::|Vector| vector
)))
440 (let* ((type (constant-form-value type env
))
441 (length (1- (length x
)))
442 ;; Special case, since strings are unions
443 (string-p (member type
'(string simple-string
)))
445 (careful-values-specifier-type type
))))
447 (and (array-type-p ctype
)
448 (csubtypep ctype
(specifier-type '(array * (*))))
449 (proper-list-of-length-p (array-type-dimensions ctype
) 1)
450 (or (eq (car (array-type-dimensions ctype
)) '*)
451 (eq (car (array-type-dimensions ctype
)) length
))))
453 :element-type
',(if string-p
455 (nth-value 1 (simplify-vector-type ctype
)))
456 :initial-contents
,x
)
460 ;;; This baby is a bit of a monster, but it takes care of any MAKE-ARRAY
461 ;;; call which creates a vector with a known element type -- and tries
462 ;;; to do a good job with all the different ways it can happen.
463 (defun transform-make-array-vector (length element-type initial-element
464 initial-contents call
)
465 (aver (or (not element-type
) (constant-lvar-p element-type
)))
466 (let* ((c-length (when (constant-lvar-p length
)
467 (lvar-value length
)))
468 (elt-spec (if element-type
469 (lvar-value element-type
)
471 (elt-ctype (ir1-transform-specifier-type elt-spec
))
472 (saetp (if (unknown-type-p elt-ctype
)
473 (give-up-ir1-transform "~S is an unknown type: ~S"
474 :element-type elt-spec
)
475 (find-saetp-by-ctype elt-ctype
)))
476 (default-initial-element (sb!vm
:saetp-initial-element-default saetp
))
477 (n-bits (sb!vm
:saetp-n-bits saetp
))
478 (typecode (sb!vm
:saetp-typecode saetp
))
479 (n-pad-elements (sb!vm
:saetp-n-pad-elements saetp
))
482 (ceiling (* (+ c-length n-pad-elements
) n-bits
)
484 (let ((padded-length-form (if (zerop n-pad-elements
)
486 `(+ length
,n-pad-elements
))))
489 ((>= n-bits sb
!vm
:n-word-bits
)
490 `(* ,padded-length-form
492 ,(the fixnum
(/ n-bits sb
!vm
:n-word-bits
))))
494 (let ((n-elements-per-word (/ sb
!vm
:n-word-bits n-bits
)))
495 (declare (type index n-elements-per-word
)) ; i.e., not RATIO
496 `(ceiling (truly-the index
,padded-length-form
)
497 ,n-elements-per-word
)))))))
499 `(simple-array ,(sb!vm
:saetp-specifier saetp
) (,(or c-length
'*))))
501 `(truly-the ,result-spec
502 (allocate-vector ,typecode
(the index length
) ,n-words-form
))))
503 (cond ((and initial-element initial-contents
)
504 (abort-ir1-transform "Both ~S and ~S specified."
505 :initial-contents
:initial-element
))
506 ;; :INITIAL-CONTENTS (LIST ...), (VECTOR ...) and `(1 1 ,x) with a
508 ((and initial-contents c-length
509 (lvar-matches initial-contents
510 :fun-names
'(list vector
511 sb
!impl
::|List| sb
!impl
::|Vector|
)
512 :arg-count c-length
))
513 (let ((parameters (eliminate-keyword-args
514 call
1 '((:element-type element-type
)
515 (:initial-contents initial-contents
))))
516 (elt-vars (make-gensym-list c-length
))
517 (lambda-list '(length)))
518 (splice-fun-args initial-contents
:any c-length
)
519 (dolist (p parameters
)
522 (if (eq p
'initial-contents
)
525 `(lambda ,lambda-list
526 (declare (type ,elt-spec
,@elt-vars
)
527 (ignorable ,@lambda-list
))
528 (truly-the ,result-spec
529 (initialize-vector ,alloc-form
,@elt-vars
)))))
530 ;; constant :INITIAL-CONTENTS and LENGTH
531 ((and initial-contents c-length
(constant-lvar-p initial-contents
))
532 (let ((contents (lvar-value initial-contents
)))
533 (unless (= c-length
(length contents
))
534 (abort-ir1-transform "~S has ~S elements, vector length is ~S."
535 :initial-contents
(length contents
) c-length
))
536 (let ((parameters (eliminate-keyword-args
537 call
1 '((:element-type element-type
)
538 (:initial-contents initial-contents
)))))
539 `(lambda (length ,@parameters
)
540 (declare (ignorable ,@parameters
))
541 (truly-the ,result-spec
542 (initialize-vector ,alloc-form
543 ,@(map 'list
(lambda (elt)
544 `(the ,elt-spec
',elt
))
546 ;; any other :INITIAL-CONTENTS
548 (let ((parameters (eliminate-keyword-args
549 call
1 '((:element-type element-type
)
550 (:initial-contents initial-contents
)))))
551 `(lambda (length ,@parameters
)
552 (declare (ignorable ,@parameters
))
553 (unless (= length
(length initial-contents
))
554 (error "~S has ~S elements, vector length is ~S."
555 :initial-contents
(length initial-contents
) length
))
556 (truly-the ,result-spec
557 (replace ,alloc-form initial-contents
)))))
558 ;; :INITIAL-ELEMENT, not EQL to the default
559 ((and initial-element
560 (or (not (constant-lvar-p initial-element
))
561 (not (eql default-initial-element
(lvar-value initial-element
)))))
562 (let ((parameters (eliminate-keyword-args
563 call
1 '((:element-type element-type
)
564 (:initial-element initial-element
))))
565 (init (if (constant-lvar-p initial-element
)
566 (list 'quote
(lvar-value initial-element
))
568 `(lambda (length ,@parameters
)
569 (declare (ignorable ,@parameters
))
570 (truly-the ,result-spec
571 (fill ,alloc-form
(the ,elt-spec
,init
))))))
572 ;; just :ELEMENT-TYPE, or maybe with :INITIAL-ELEMENT EQL to the
576 (unless (ctypep default-initial-element elt-ctype
)
577 ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE
578 ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If
579 ;; INITIAL-ELEMENT is not supplied, the consequences of later
580 ;; reading an uninitialized element of new-array are undefined,"
581 ;; so this could be legal code as long as the user plans to
582 ;; write before he reads, and if he doesn't we're free to do
583 ;; anything we like. But in case the user doesn't know to write
584 ;; elements before he reads elements (or to read manuals before
585 ;; he writes code:-), we'll signal a STYLE-WARNING in case he
586 ;; didn't realize this.
588 (compiler-warn "~S ~S is not a ~S"
589 :initial-element default-initial-element
591 (compiler-style-warn "The default initial element ~S is not a ~S."
592 default-initial-element
594 (let ((parameters (eliminate-keyword-args
595 call
1 '((:element-type element-type
)
596 (:initial-element initial-element
)))))
597 `(lambda (length ,@parameters
)
598 (declare (ignorable ,@parameters
))
601 ;;; IMPORTANT: The order of these three MAKE-ARRAY forms matters: the least
602 ;;; specific must come first, otherwise suboptimal transforms will result for
605 (deftransform make-array
((dims &key initial-element element-type
606 adjustable fill-pointer
)
609 (delay-ir1-transform node
:constraint
)
610 (let* ((eltype (cond ((not element-type
) t
)
611 ((not (constant-lvar-p element-type
))
612 (give-up-ir1-transform
613 "ELEMENT-TYPE is not constant."))
615 (lvar-value element-type
))))
616 (eltype-type (ir1-transform-specifier-type eltype
))
617 (saetp (if (unknown-type-p eltype-type
)
618 (give-up-ir1-transform
619 "ELEMENT-TYPE ~s is not a known type"
622 sb
!vm
:*specialized-array-element-type-properties
*
623 :key
#'sb
!vm
:saetp-ctype
625 (creation-form `(%make-array
628 (sb!vm
:saetp-typecode saetp
)
629 (give-up-ir1-transform))
630 ,(sb!vm
:saetp-n-bits saetp
)
632 '(:fill-pointer fill-pointer
))
634 '(:adjustable adjustable
)))))
635 (cond ((or (not initial-element
)
636 (and (constant-lvar-p initial-element
)
637 (eql (lvar-value initial-element
)
638 (sb!vm
:saetp-initial-element-default saetp
))))
641 ;; error checking for target, disabled on the host because
642 ;; (CTYPE-OF #\Null) is not possible.
644 (when (constant-lvar-p initial-element
)
645 (let ((value (lvar-value initial-element
)))
647 ((not (ctypep value
(sb!vm
:saetp-ctype saetp
)))
648 ;; this case will cause an error at runtime, so we'd
649 ;; better WARN about it now.
650 (warn 'array-initial-element-mismatch
651 :format-control
"~@<~S is not a ~S (which is the ~
656 (type-specifier (sb!vm
:saetp-ctype saetp
))
657 'upgraded-array-element-type
659 ((not (ctypep value eltype-type
))
660 ;; this case will not cause an error at runtime, but
661 ;; it's still worth STYLE-WARNing about.
662 (compiler-style-warn "~S is not a ~S."
664 `(let ((array ,creation-form
))
665 (multiple-value-bind (vector)
666 (%data-vector-and-index array
0)
667 (fill vector
(the ,(sb!vm
:saetp-specifier saetp
) initial-element
)))
670 ;;; The list type restriction does not ensure that the result will be a
671 ;;; multi-dimensional array. But the lack of adjustable, fill-pointer,
672 ;;; and displaced-to keywords ensures that it will be simple.
674 ;;; FIXME: should we generalize this transform to non-simple (though
675 ;;; non-displaced-to) arrays, given that we have %WITH-ARRAY-DATA to
676 ;;; deal with those? Maybe when the DEFTRANSFORM
677 ;;; %DATA-VECTOR-AND-INDEX in the VECTOR case problem is solved? --
679 (deftransform make-array
((dims &key
680 element-type initial-element initial-contents
)
682 (:element-type
(constant-arg *))
684 (:initial-contents
*))
688 (when (lvar-matches dims
:fun-names
'(list) :arg-count
1)
689 (let ((length (car (splice-fun-args dims
:any
1))))
690 (return-from make-array
691 (transform-make-array-vector length
696 (unless (constant-lvar-p dims
)
697 (give-up-ir1-transform
698 "The dimension list is not constant; cannot open code array creation."))
699 (let ((dims (lvar-value dims
))
700 (element-type-ctype (and (constant-lvar-p element-type
)
701 (ir1-transform-specifier-type
702 (lvar-value element-type
)))))
703 (when (contains-unknown-type-p element-type-ctype
)
704 (give-up-ir1-transform))
705 (unless (every (lambda (x) (typep x
'(integer 0))) dims
)
706 (give-up-ir1-transform
707 "The dimension list contains something other than an integer: ~S"
709 (if (= (length dims
) 1)
710 `(make-array ',(car dims
)
712 '(:element-type element-type
))
713 ,@(when initial-element
714 '(:initial-element initial-element
))
715 ,@(when initial-contents
716 '(:initial-contents initial-contents
)))
717 (let* ((total-size (reduce #'* dims
))
720 ,(cond ((null element-type
) t
)
722 (sb!xc
:upgraded-array-element-type
723 (lvar-value element-type
)))
725 ,(make-list rank
:initial-element
'*))))
726 `(let ((header (make-array-header sb
!vm
:simple-array-widetag
,rank
))
727 (data (make-array ,total-size
729 '(:element-type element-type
))
730 ,@(when initial-element
731 '(:initial-element initial-element
)))))
732 ,@(when initial-contents
733 ;; FIXME: This is could be open coded at least a bit too
734 `((sb!impl
::fill-data-vector data
',dims initial-contents
)))
735 (setf (%array-fill-pointer header
) ,total-size
)
736 (setf (%array-fill-pointer-p header
) nil
)
737 (setf (%array-available-elements header
) ,total-size
)
738 (setf (%array-data-vector header
) data
)
739 (setf (%array-displaced-p header
) nil
)
740 (setf (%array-displaced-from header
) nil
)
742 (mapcar (lambda (dim)
743 `(setf (%array-dimension header
,(incf axis
))
746 (truly-the ,spec header
)))))))
748 (deftransform make-array
((dims &key element-type initial-element initial-contents
)
750 (:element-type
(constant-arg *))
752 (:initial-contents
*))
755 (transform-make-array-vector dims
761 ;;;; miscellaneous properties of arrays
763 ;;; Transforms for various array properties. If the property is know
764 ;;; at compile time because of a type spec, use that constant value.
766 ;;; Most of this logic may end up belonging in code/late-type.lisp;
767 ;;; however, here we also need the -OR-GIVE-UP for the transforms, and
768 ;;; maybe this is just too sloppy for actual type logic. -- CSR,
770 (defun array-type-dimensions-or-give-up (type)
771 (labels ((maybe-array-type-dimensions (type)
774 (array-type-dimensions type
))
776 (let* ((types (remove nil
(mapcar #'maybe-array-type-dimensions
777 (union-type-types type
))))
778 (result (car types
)))
779 (dolist (other (cdr types
) result
)
780 (unless (equal result other
)
781 (give-up-ir1-transform
782 "~@<dimensions of arrays in union type ~S do not match~:@>"
783 (type-specifier type
))))))
785 (let* ((types (remove nil
(mapcar #'maybe-array-type-dimensions
786 (intersection-type-types type
))))
787 (result (car types
)))
788 (dolist (other (cdr types
) result
)
789 (unless (equal result other
)
791 "~@<dimensions of arrays in intersection type ~S do not match~:@>"
792 (type-specifier type
)))))))))
793 (or (maybe-array-type-dimensions type
)
794 (give-up-ir1-transform
795 "~@<don't know how to extract array dimensions from type ~S~:@>"
796 (type-specifier type
)))))
798 (defun conservative-array-type-complexp (type)
800 (array-type (array-type-complexp type
))
802 (let ((types (union-type-types type
)))
803 (aver (> (length types
) 1))
804 (let ((result (conservative-array-type-complexp (car types
))))
805 (dolist (type (cdr types
) result
)
806 (unless (eq (conservative-array-type-complexp type
) result
)
807 (return-from conservative-array-type-complexp
:maybe
))))))
808 ;; FIXME: intersection type
811 ;; Let type derivation handle constant cases. We only do easy strength
813 (deftransform array-rank
((array) (array) * :node node
)
814 (let ((array-type (lvar-type array
)))
815 (cond ((eq t
(and (array-type-p array-type
)
816 (array-type-complexp array-type
)))
817 '(%array-rank array
))
819 (delay-ir1-transform node
:constraint
)
820 `(if (array-header-p array
)
824 (defun derive-array-rank (ctype)
825 (let ((array (specifier-type 'array
)))
827 (cond ((not (types-equal-or-intersect x array
))
828 '()) ; Definitely not an array!
830 (let ((dims (array-type-dimensions x
)))
833 (list (length dims
)))))
836 ;; Might as well catch some easy negation cases.
839 (let ((dims (array-type-dimensions x
)))
842 ((every (lambda (dim)
845 (list (length dims
)))
849 (declare (dynamic-extent #'over
#'under
))
850 (multiple-value-bind (not-p ranks
)
851 (list-abstract-type-function ctype
#'over
:under
#'under
)
852 (cond ((eql ranks
'*)
856 (specifier-type `(not (member ,@ranks
))))
858 (specifier-type `(member ,@ranks
))))))))
860 (defoptimizer (array-rank derive-type
) ((array))
861 (derive-array-rank (lvar-type array
)))
863 (defoptimizer (%array-rank derive-type
) ((array))
864 (derive-array-rank (lvar-type array
)))
866 ;;; If we know the dimensions at compile time, just use it. Otherwise,
867 ;;; if we can tell that the axis is in bounds, convert to
868 ;;; %ARRAY-DIMENSION (which just indirects the array header) or length
869 ;;; (if it's simple and a vector).
870 (deftransform array-dimension
((array axis
)
872 (unless (constant-lvar-p axis
)
873 (give-up-ir1-transform "The axis is not constant."))
874 ;; Dimensions may change thanks to ADJUST-ARRAY, so we need the
875 ;; conservative type.
876 (let ((array-type (lvar-conservative-type array
))
877 (axis (lvar-value axis
)))
878 (let ((dims (array-type-dimensions-or-give-up array-type
)))
880 (give-up-ir1-transform
881 "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime."))
882 (unless (> (length dims
) axis
)
883 (abort-ir1-transform "The array has dimensions ~S, ~W is too large."
886 (let ((dim (nth axis dims
)))
887 (cond ((integerp dim
)
890 (ecase (conservative-array-type-complexp array-type
)
892 '(%array-dimension array
0))
894 '(vector-length array
))
896 `(if (array-header-p array
)
897 (%array-dimension array axis
)
898 (vector-length array
)))))
900 '(%array-dimension array axis
)))))))
902 ;;; If the length has been declared and it's simple, just return it.
903 (deftransform length
((vector)
904 ((simple-array * (*))))
905 (let ((type (lvar-type vector
)))
906 (let ((dims (array-type-dimensions-or-give-up type
)))
907 (unless (and (listp dims
) (integerp (car dims
)))
908 (give-up-ir1-transform
909 "Vector length is unknown, must call LENGTH at runtime."))
912 ;;; All vectors can get their length by using VECTOR-LENGTH. If it's
913 ;;; simple, it will extract the length slot from the vector. It it's
914 ;;; complex, it will extract the fill pointer slot from the array
916 (deftransform length
((vector) (vector))
917 '(vector-length vector
))
919 ;;; If a simple array with known dimensions, then VECTOR-LENGTH is a
920 ;;; compile-time constant.
921 (deftransform vector-length
((vector))
922 (let ((vtype (lvar-type vector
)))
923 (let ((dim (first (array-type-dimensions-or-give-up vtype
))))
925 (give-up-ir1-transform))
926 (when (conservative-array-type-complexp vtype
)
927 (give-up-ir1-transform))
930 ;;; Again, if we can tell the results from the type, just use it.
931 ;;; Otherwise, if we know the rank, convert into a computation based
932 ;;; on array-dimension. We can wrap a TRULY-THE INDEX around the
933 ;;; multiplications because we know that the total size must be an
935 (deftransform array-total-size
((array)
937 (let ((array-type (lvar-type array
)))
938 (let ((dims (array-type-dimensions-or-give-up array-type
)))
940 (give-up-ir1-transform "can't tell the rank at compile time"))
942 (do ((form 1 `(truly-the index
943 (* (array-dimension array
,i
) ,form
)))
945 ((= i
(length dims
)) form
))
946 (reduce #'* dims
)))))
948 ;;; Only complex vectors have fill pointers.
949 (deftransform array-has-fill-pointer-p
((array))
950 (let ((array-type (lvar-type array
)))
951 (let ((dims (array-type-dimensions-or-give-up array-type
)))
952 (if (and (listp dims
) (not (= (length dims
) 1)))
954 (ecase (conservative-array-type-complexp array-type
)
960 (give-up-ir1-transform
961 "The array type is ambiguous; must call ~
962 ARRAY-HAS-FILL-POINTER-P at runtime.")))))))
964 ;;; Primitive used to verify indices into arrays. If we can tell at
965 ;;; compile-time or we are generating unsafe code, don't bother with
967 (deftransform %check-bound
((array dimension index
) * * :node node
)
968 (cond ((policy node
(= insert-array-bounds-checks
0))
970 ((not (constant-lvar-p dimension
))
971 (give-up-ir1-transform))
973 (let ((dim (lvar-value dimension
)))
974 ;; FIXME: Can SPEED > SAFETY weaken this check to INTEGER?
975 `(the (integer 0 (,dim
)) index
)))))
979 ;;; This checks to see whether the array is simple and the start and
980 ;;; end are in bounds. If so, it proceeds with those values.
981 ;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that %WITH-ARRAY-DATA
982 ;;; may be further optimized.
984 ;;; Given any ARRAY, bind DATA-VAR to the array's data vector and
985 ;;; START-VAR and END-VAR to the start and end of the designated
986 ;;; portion of the data vector. SVALUE and EVALUE are any start and
987 ;;; end specified to the original operation, and are factored into the
988 ;;; bindings of START-VAR and END-VAR. OFFSET-VAR is the cumulative
989 ;;; offset of all displacements encountered, and does not include
992 ;;; When FORCE-INLINE is set, the underlying %WITH-ARRAY-DATA form is
993 ;;; forced to be inline, overriding the ordinary judgment of the
994 ;;; %WITH-ARRAY-DATA DEFTRANSFORMs. Ordinarily the DEFTRANSFORMs are
995 ;;; fairly picky about their arguments, figuring that if you haven't
996 ;;; bothered to get all your ducks in a row, you probably don't care
997 ;;; that much about speed anyway! But in some cases it makes sense to
998 ;;; do type testing inside %WITH-ARRAY-DATA instead of outside, and
999 ;;; the DEFTRANSFORM can't tell that that's going on, so it can make
1000 ;;; sense to use FORCE-INLINE option in that case.
1001 (sb!xc
:defmacro with-array-data
(((data-var array
&key offset-var
)
1002 (start-var &optional
(svalue 0))
1003 (end-var &optional
(evalue nil
))
1004 &key force-inline check-fill-pointer
)
1007 (once-only ((n-array array
)
1008 (n-svalue `(the index
,svalue
))
1009 (n-evalue `(the (or index null
) ,evalue
)))
1010 (let ((check-bounds (policy env
(plusp insert-array-bounds-checks
))))
1011 `(multiple-value-bind (,data-var
1014 ,@(when offset-var
`(,offset-var
)))
1015 (if (not (array-header-p ,n-array
))
1016 (let ((,n-array
,n-array
))
1017 (declare (type (simple-array * (*)) ,n-array
))
1018 ,(once-only ((n-len (if check-fill-pointer
1020 `(array-total-size ,n-array
)))
1021 (n-end `(or ,n-evalue
,n-len
)))
1023 `(if (<= 0 ,n-svalue
,n-end
,n-len
)
1024 (values ,n-array
,n-svalue
,n-end
0)
1025 ,(if check-fill-pointer
1026 `(sequence-bounding-indices-bad-error ,n-array
,n-svalue
,n-evalue
)
1027 `(array-bounding-indices-bad-error ,n-array
,n-svalue
,n-evalue
)))
1028 `(values ,n-array
,n-svalue
,n-end
0))))
1030 `(%with-array-data-macro
,n-array
,n-svalue
,n-evalue
1031 :check-bounds
,check-bounds
1032 :check-fill-pointer
,check-fill-pointer
)
1033 (if check-fill-pointer
1034 `(%with-array-data
/fp
,n-array
,n-svalue
,n-evalue
)
1035 `(%with-array-data
,n-array
,n-svalue
,n-evalue
))))
1038 ;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in
1039 ;;; DEFTRANSFORMs and DEFUNs.
1040 (def!macro %with-array-data-macro
(array
1047 (with-unique-names (size defaulted-end data cumulative-offset
)
1048 `(let* ((,size
,(if check-fill-pointer
1050 `(array-total-size ,array
)))
1051 (,defaulted-end
(or ,end
,size
)))
1052 ,@(when check-bounds
1053 `((unless (<= ,start
,defaulted-end
,size
)
1054 ,(if check-fill-pointer
1055 `(sequence-bounding-indices-bad-error ,array
,start
,end
)
1056 `(array-bounding-indices-bad-error ,array
,start
,end
)))))
1057 (do ((,data
,array
(%array-data-vector
,data
))
1058 (,cumulative-offset
0
1059 (+ ,cumulative-offset
1060 (%array-displacement
,data
))))
1061 ((not (array-header-p ,data
))
1062 (values (the (simple-array ,element-type
1) ,data
)
1063 (the index
(+ ,cumulative-offset
,start
))
1064 (the index
(+ ,cumulative-offset
,defaulted-end
))
1065 (the index
,cumulative-offset
)))
1066 (declare (type index
,cumulative-offset
))))))
1068 (defun transform-%with-array-data
/mumble
(array node check-fill-pointer
)
1069 (let ((element-type (upgraded-element-type-specifier-or-give-up array
))
1070 (type (lvar-type array
))
1071 (check-bounds (policy node
(plusp insert-array-bounds-checks
))))
1072 (if (and (array-type-p type
)
1073 (not (array-type-complexp type
))
1074 (listp (array-type-dimensions type
))
1075 (not (null (cdr (array-type-dimensions type
)))))
1076 ;; If it's a simple multidimensional array, then just return
1077 ;; its data vector directly rather than going through
1078 ;; %WITH-ARRAY-DATA-MACRO. SBCL doesn't generally generate
1079 ;; code that would use this currently, but we have encouraged
1080 ;; users to use WITH-ARRAY-DATA and we may use it ourselves at
1081 ;; some point in the future for optimized libraries or
1084 `(let* ((data (truly-the (simple-array ,element-type
(*))
1085 (%array-data-vector array
)))
1087 (real-end (or end len
)))
1088 (unless (<= 0 start data-end lend
)
1089 (sequence-bounding-indices-bad-error array start end
))
1090 (values data
0 real-end
0))
1091 `(let ((data (truly-the (simple-array ,element-type
(*))
1092 (%array-data-vector array
))))
1093 (values data
0 (or end
(length data
)) 0)))
1094 `(%with-array-data-macro array start end
1095 :check-fill-pointer
,check-fill-pointer
1096 :check-bounds
,check-bounds
1097 :element-type
,element-type
))))
1099 ;; It might very well be reasonable to allow general ARRAY here, I
1100 ;; just haven't tried to understand the performance issues involved.
1101 ;; -- WHN, and also CSR 2002-05-26
1102 (deftransform %with-array-data
((array start end
)
1103 ((or vector simple-array
) index
(or index null
) t
)
1106 :policy
(> speed space
))
1107 "inline non-SIMPLE-vector-handling logic"
1108 (transform-%with-array-data
/mumble array node nil
))
1109 (deftransform %with-array-data
/fp
((array start end
)
1110 ((or vector simple-array
) index
(or index null
) t
)
1113 :policy
(> speed space
))
1114 "inline non-SIMPLE-vector-handling logic"
1115 (transform-%with-array-data
/mumble array node t
))
1117 ;;;; array accessors
1119 ;;; We convert all typed array accessors into AREF and (SETF AREF) with type
1120 ;;; assertions on the array.
1121 (macrolet ((define-bit-frob (reffer simplep
)
1123 (define-source-transform ,reffer
(a &rest i
)
1124 `(aref (the (,',(if simplep
'simple-array
'array
)
1126 ,(mapcar (constantly '*) i
))
1128 (define-source-transform (setf ,reffer
) (value a
&rest i
)
1129 `(setf (aref (the (,',(if simplep
'simple-array
'array
)
1131 ,(mapcar (constantly '*) i
))
1134 (define-bit-frob sbit t
)
1135 (define-bit-frob bit nil
))
1137 (macrolet ((define-frob (reffer setter type
)
1139 (define-source-transform ,reffer
(a i
)
1140 `(aref (the ,',type
,a
) ,i
))
1141 (define-source-transform ,setter
(a i v
)
1142 `(setf (aref (the ,',type
,a
) ,i
) ,v
)))))
1143 (define-frob schar %scharset simple-string
)
1144 (define-frob char %charset string
))
1146 ;;; We transform SVREF and %SVSET directly into DATA-VECTOR-REF/SET: this is
1147 ;;; around 100 times faster than going through the general-purpose AREF
1148 ;;; transform which ends up doing a lot of work -- and introducing many
1149 ;;; intermediate lambdas, each meaning a new trip through the compiler -- to
1150 ;;; get the same result.
1152 ;;; FIXME: [S]CHAR, and [S]BIT above would almost certainly benefit from a similar
1154 (define-source-transform svref
(vector index
)
1155 (let ((elt-type (or (when (symbolp vector
)
1156 (let ((var (lexenv-find vector vars
)))
1157 (when (lambda-var-p var
)
1159 (array-type-declared-element-type (lambda-var-type var
))))))
1161 (with-unique-names (n-vector)
1162 `(let ((,n-vector
,vector
))
1163 (the ,elt-type
(data-vector-ref
1164 (the simple-vector
,n-vector
)
1165 (%check-bound
,n-vector
(length ,n-vector
) ,index
)))))))
1167 (define-source-transform %svset
(vector index value
)
1168 (let ((elt-type (or (when (symbolp vector
)
1169 (let ((var (lexenv-find vector vars
)))
1170 (when (lambda-var-p var
)
1172 (array-type-declared-element-type (lambda-var-type var
))))))
1174 (with-unique-names (n-vector)
1175 `(let ((,n-vector
,vector
))
1176 (truly-the ,elt-type
(data-vector-set
1177 (the simple-vector
,n-vector
)
1178 (%check-bound
,n-vector
(length ,n-vector
) ,index
)
1179 (the ,elt-type
,value
)))))))
1181 (macrolet (;; This is a handy macro for computing the row-major index
1182 ;; given a set of indices. We wrap each index with a call
1183 ;; to %CHECK-BOUND to ensure that everything works out
1184 ;; correctly. We can wrap all the interior arithmetic with
1185 ;; TRULY-THE INDEX because we know the resultant
1186 ;; row-major index must be an index.
1187 (with-row-major-index ((array indices index
&optional new-value
)
1189 `(let (n-indices dims
)
1190 (dotimes (i (length ,indices
))
1191 (push (make-symbol (format nil
"INDEX-~D" i
)) n-indices
)
1192 (push (make-symbol (format nil
"DIM-~D" i
)) dims
))
1193 (setf n-indices
(nreverse n-indices
))
1194 (setf dims
(nreverse dims
))
1195 `(lambda (,@',(when new-value
(list new-value
))
1196 ,',array
,@n-indices
)
1197 (declare (ignorable ,',array
))
1198 (let* (,@(let ((,index -
1))
1199 (mapcar (lambda (name)
1200 `(,name
(array-dimension
1207 (do* ((dims dims
(cdr dims
))
1208 (indices n-indices
(cdr indices
))
1209 (last-dim nil
(car dims
))
1210 (form `(%check-bound
,',array
1222 ((null (cdr dims
)) form
)))))
1225 ;; Just return the index after computing it.
1226 (deftransform array-row-major-index
((array &rest indices
))
1227 (with-row-major-index (array indices index
)
1230 ;; Convert AREF and (SETF AREF) into a HAIRY-DATA-VECTOR-REF (or
1231 ;; HAIRY-DATA-VECTOR-SET) with the set of indices replaced with the an
1232 ;; expression for the row major index.
1233 (deftransform aref
((array &rest indices
))
1234 (with-row-major-index (array indices index
)
1235 (hairy-data-vector-ref array index
)))
1237 (deftransform (setf aref
) ((new-value array
&rest subscripts
))
1238 (with-row-major-index (array subscripts index new-value
)
1239 (hairy-data-vector-set array index new-value
))))
1241 ;; For AREF of vectors we do the bounds checking in the callee. This
1242 ;; lets us do a significantly more efficient check for simple-arrays
1243 ;; without bloating the code. If we already know the type of the array
1244 ;; with sufficient precision, skip directly to DATA-VECTOR-REF.
1245 (deftransform aref
((array index
) (t t
) * :node node
)
1246 (let* ((type (lvar-type array
))
1247 (element-ctype (array-type-upgraded-element-type type
)))
1249 ((eql element-ctype
*empty-type
*)
1250 `(data-nil-vector-ref array index
))
1251 ((and (array-type-p type
)
1252 (null (array-type-complexp type
))
1253 (not (eql element-ctype
*wild-type
*))
1254 (eql (length (array-type-dimensions type
)) 1))
1255 (let* ((declared-element-ctype (array-type-declared-element-type type
))
1257 `(data-vector-ref array
1258 (%check-bound array
(array-dimension array
0) index
))))
1259 (if (type= declared-element-ctype element-ctype
)
1261 `(the ,(type-specifier declared-element-ctype
) ,bare-form
))))
1262 ((policy node
(zerop insert-array-bounds-checks
))
1263 `(hairy-data-vector-ref array index
))
1264 (t `(hairy-data-vector-ref/check-bounds array index
)))))
1266 (deftransform (setf aref
) ((new-value array index
) (t t t
) * :node node
)
1267 (if (policy node
(zerop insert-array-bounds-checks
))
1268 `(hairy-data-vector-set array index new-value
)
1269 `(hairy-data-vector-set/check-bounds array index new-value
)))
1271 ;;; But if we find out later that there's some useful type information
1272 ;;; available, switch back to the normal one to give other transforms
1274 (macrolet ((define (name transform-to extra extra-type
)
1275 (declare (ignore extra-type
))
1276 `(deftransform ,name
((array index
,@extra
))
1277 (let* ((type (lvar-type array
))
1278 (element-type (array-type-upgraded-element-type type
))
1279 (declared-type (type-specifier
1280 (array-type-declared-element-type type
))))
1281 ;; If an element type has been declared, we want to
1282 ;; use that information it for type checking (even
1283 ;; if the access can't be optimized due to the array
1284 ;; not being simple).
1285 (when (and (eql element-type
*wild-type
*)
1286 ;; This type logic corresponds to the special
1287 ;; case for strings in HAIRY-DATA-VECTOR-REF
1288 ;; (generic/vm-tran.lisp)
1289 (not (csubtypep type
(specifier-type 'simple-string
))))
1290 (when (or (not (array-type-p type
))
1291 ;; If it's a simple array, we might be able
1292 ;; to inline the access completely.
1293 (not (null (array-type-complexp type
))))
1294 (give-up-ir1-transform
1295 "Upgraded element type of array is not known at compile time.")))
1297 ``(truly-the ,declared-type
1298 (,',transform-to array
1300 (array-dimension array
0)
1302 (the ,declared-type
,@',extra
)))
1303 ``(the ,declared-type
1304 (,',transform-to array
1306 (array-dimension array
0)
1308 (define hairy-data-vector-ref
/check-bounds
1309 hairy-data-vector-ref nil nil
)
1310 (define hairy-data-vector-set
/check-bounds
1311 hairy-data-vector-set
(new-value) (*)))
1313 ;;; Just convert into a HAIRY-DATA-VECTOR-REF (or
1314 ;;; HAIRY-DATA-VECTOR-SET) after checking that the index is inside the
1315 ;;; array total size.
1316 (deftransform row-major-aref
((array index
))
1317 `(hairy-data-vector-ref array
1318 (%check-bound array
(array-total-size array
) index
)))
1319 (deftransform %set-row-major-aref
((array index new-value
))
1320 `(hairy-data-vector-set array
1321 (%check-bound array
(array-total-size array
) index
)
1324 ;;;; bit-vector array operation canonicalization
1326 ;;;; We convert all bit-vector operations to have the result array
1327 ;;;; specified. This allows any result allocation to be open-coded,
1328 ;;;; and eliminates the need for any VM-dependent transforms to handle
1331 (macrolet ((def (fun)
1333 (deftransform ,fun
((bit-array-1 bit-array-2
1334 &optional result-bit-array
)
1335 (bit-vector bit-vector
&optional null
) *
1336 :policy
(>= speed space
))
1337 `(,',fun bit-array-1 bit-array-2
1338 (make-array (array-dimension bit-array-1
0) :element-type
'bit
)))
1339 ;; If result is T, make it the first arg.
1340 (deftransform ,fun
((bit-array-1 bit-array-2 result-bit-array
)
1341 (bit-vector bit-vector
(eql t
)) *)
1342 `(,',fun bit-array-1 bit-array-2 bit-array-1
)))))
1354 ;;; Similar for BIT-NOT, but there is only one arg...
1355 (deftransform bit-not
((bit-array-1 &optional result-bit-array
)
1356 (bit-vector &optional null
) *
1357 :policy
(>= speed space
))
1358 '(bit-not bit-array-1
1359 (make-array (array-dimension bit-array-1
0) :element-type
'bit
)))
1360 (deftransform bit-not
((bit-array-1 result-bit-array
)
1361 (bit-vector (eql t
)))
1362 '(bit-not bit-array-1 bit-array-1
))
1364 ;;; Pick off some constant cases.
1365 (defoptimizer (array-header-p derive-type
) ((array))
1366 (let ((type (lvar-type array
)))
1367 (cond ((not (array-type-p type
))
1368 ;; FIXME: use analogue of ARRAY-TYPE-DIMENSIONS-OR-GIVE-UP
1371 (let ((dims (array-type-dimensions type
)))
1372 (cond ((csubtypep type
(specifier-type '(simple-array * (*))))
1374 (specifier-type 'null
))
1375 ((and (listp dims
) (/= (length dims
) 1))
1376 ;; multi-dimensional array, will have a header
1377 (specifier-type '(eql t
)))
1378 ((eql (array-type-complexp type
) t
)
1379 (specifier-type '(eql t
)))