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 (and (typep ,arg
'(and fixnum unsigned-byte
))
169 (< ,arg
(array-dimension array
0))))))
171 (give-up-ir1-transform
173 "~@<lower array bounds unknown or negative and upper bounds not ~
176 (integerp x
))) ; might be NIL or *
177 (let ((dimensions (catch-give-up-ir1-transform
178 ((array-type-dimensions-or-give-up
179 (lvar-conservative-type array
))
181 (give-up (car args
)))))
182 ;; Might be *. (Note: currently this is never true, because the type
183 ;; derivation infers the rank from the call to ARRAY-IN-BOUNDS-P, but
184 ;; let's keep this future proof.)
185 (when (eq '* dimensions
)
186 (give-up "array bounds unknown"))
187 ;; shortcut for zero dimensions
188 (when (some (lambda (dim)
189 (and (bound-known-p dim
) (zerop dim
)))
192 ;; we first collect the subscripts LVARs' bounds and see whether
193 ;; we can already decide on the result of the optimization without
194 ;; even taking a look at the dimensions.
195 (flet ((subscript-bounds (subscript)
196 (let* ((type1 (lvar-type subscript
))
197 (type2 (if (csubtypep type1
(specifier-type 'integer
))
198 (weaken-integer-type type1
:range-only t
)
200 (low (if (integer-type-p type2
)
201 (numeric-type-low type2
)
203 (high (numeric-type-high type2
)))
205 ((and (or (not (bound-known-p low
)) (minusp low
))
206 (or (not (bound-known-p high
)) (not (minusp high
))))
207 ;; can't be sure about the lower bound and the upper bound
208 ;; does not give us a definite clue either.
210 ((and (bound-known-p high
) (minusp high
))
211 (return nil
)) ; definitely below lower bound (zero).
214 (let* ((subscripts-bounds (mapcar #'subscript-bounds subscripts
))
215 (subscripts-lower-bound (mapcar #'car subscripts-bounds
))
216 (subscripts-upper-bound (mapcar #'cdr subscripts-bounds
))
218 (mapcar (lambda (low high dim
)
220 ;; first deal with infinite bounds
221 ((some (complement #'bound-known-p
) (list low high dim
))
222 (when (and (bound-known-p dim
) (bound-known-p low
) (<= dim low
))
224 ;; now we know all bounds
228 (aver (not (minusp low
)))
232 subscripts-lower-bound
233 subscripts-upper-bound
235 (if (eql in-bounds
(length dimensions
))
239 (defoptimizer (aref derive-type
) ((array &rest indices
))
240 (assert-array-rank array
(length indices
))
241 (derive-aref-type array
))
243 (defoptimizer ((setf aref
) derive-type
) ((new-value array
&rest subscripts
))
244 (assert-array-rank array
(length subscripts
))
245 (assert-new-value-type new-value array
))
247 (macrolet ((define (name)
248 `(defoptimizer (,name derive-type
) ((array index
))
249 (declare (ignore index
))
250 (derive-aref-type array
))))
251 (define hairy-data-vector-ref
)
252 (define hairy-data-vector-ref
/check-bounds
)
253 (define data-vector-ref
))
256 (defoptimizer (data-vector-ref-with-offset derive-type
) ((array index offset
))
257 (declare (ignore index offset
))
258 (derive-aref-type array
))
260 (macrolet ((define (name)
261 `(defoptimizer (,name derive-type
) ((array index new-value
))
262 (declare (ignore index
))
263 (assert-new-value-type new-value array
))))
264 (define hairy-data-vector-set
)
265 (define hairy-data-vector-set
/check-bounds
)
266 (define data-vector-set
))
269 (defoptimizer (data-vector-set-with-offset derive-type
) ((array index offset new-value
))
270 (declare (ignore index offset
))
271 (assert-new-value-type new-value array
))
273 ;;; Figure out the type of the data vector if we know the argument
275 (defun derive-%with-array-data
/mumble-type
(array)
276 (let ((atype (lvar-type array
)))
277 (when (array-type-p atype
)
279 `(simple-array ,(type-specifier
280 (array-type-specialized-element-type atype
))
282 (defoptimizer (%with-array-data derive-type
) ((array start end
))
283 (declare (ignore start end
))
284 (derive-%with-array-data
/mumble-type array
))
285 (defoptimizer (%with-array-data
/fp derive-type
) ((array start end
))
286 (declare (ignore start end
))
287 (derive-%with-array-data
/mumble-type array
))
289 (defoptimizer (array-row-major-index derive-type
) ((array &rest indices
))
290 (assert-array-rank array
(length indices
))
293 (defoptimizer (row-major-aref derive-type
) ((array index
))
294 (declare (ignore index
))
295 (derive-aref-type array
))
297 (defoptimizer (%set-row-major-aref derive-type
) ((array index new-value
))
298 (declare (ignore index
))
299 (assert-new-value-type new-value array
))
301 (defun derive-make-array-type (dims element-type adjustable
302 fill-pointer displaced-to
)
303 (let* ((simple (and (unsupplied-or-nil adjustable
)
304 (unsupplied-or-nil displaced-to
)
305 (unsupplied-or-nil fill-pointer
)))
307 (or `(,(if simple
'simple-array
'array
)
308 ,(cond ((not element-type
) t
)
309 ((ctype-p element-type
)
310 (type-specifier element-type
))
311 ((constant-lvar-p element-type
)
312 (let ((ctype (careful-specifier-type
313 (lvar-value element-type
))))
315 ((or (null ctype
) (contains-unknown-type-p ctype
)) '*)
316 (t (sb!xc
:upgraded-array-element-type
317 (lvar-value element-type
))))))
320 ,(cond ((constant-lvar-p dims
)
321 (let* ((val (lvar-value dims
))
322 (cdims (ensure-list val
)))
326 ((csubtypep (lvar-type dims
)
327 (specifier-type 'integer
))
332 (if (and (not simple
)
333 (or (supplied-and-true adjustable
)
334 (supplied-and-true displaced-to
)
335 (supplied-and-true fill-pointer
)))
336 (careful-specifier-type `(and ,spec
(not simple-array
)))
337 (careful-specifier-type spec
))))
339 (defoptimizer (make-array derive-type
)
340 ((dims &key element-type adjustable fill-pointer displaced-to
))
341 (derive-make-array-type dims element-type adjustable
342 fill-pointer displaced-to
))
344 (defoptimizer (%make-array derive-type
)
345 ((dims widetag n-bits
&key adjustable fill-pointer displaced-to
))
346 (declare (ignore n-bits
))
347 (let ((saetp (and (constant-lvar-p widetag
)
348 (find (lvar-value widetag
)
349 sb
!vm
:*specialized-array-element-type-properties
*
350 :key
#'sb
!vm
:saetp-typecode
))))
351 (derive-make-array-type dims
(if saetp
352 (sb!vm
:saetp-ctype saetp
)
354 adjustable fill-pointer displaced-to
)))
359 ;;; Convert VECTOR into a MAKE-ARRAY.
360 (define-source-transform vector
(&rest elements
)
361 `(make-array ,(length elements
) :initial-contents
(list ,@elements
)))
363 ;;; Just convert it into a MAKE-ARRAY.
364 (deftransform make-string
((length &key
365 (element-type 'character
)
367 #.
*default-init-char-form
*)))
368 `(the simple-string
(make-array (the index length
)
369 :element-type element-type
370 ,@(when initial-element
371 '(:initial-element initial-element
)))))
373 ;; Traverse the :INTIAL-CONTENTS argument to an array constructor call,
374 ;; changing the skeleton of the data to be constructed by calls to LIST
375 ;; and wrapping some declarations around each array cell's constructor.
376 ;; If a macro is involved, expand it before traversing.
378 ;; - Despite the effort to handle multidimensional arrays here,
379 ;; an array-header will not be stack-allocated, so the data won't be either.
380 ;; - inline functions whose behavior is merely to call LIST don't work
381 ;; e.g. :INITIAL-CONTENTS (MY-LIST a b) ; where MY-LIST is inline
382 ;; ; and effectively just (LIST ...)
383 (defun rewrite-initial-contents (rank initial-contents env
)
384 (named-let recurse
((rank rank
) (data initial-contents
))
385 (declare (type index rank
))
387 (flet ((sequence-constructor-p (form)
388 (member (car form
) '(sb!impl
::|List| list
389 sb
!impl
::|Vector| vector
))))
391 (cond ((not (listp data
)) data
)
392 ((sequence-constructor-p data
)
393 `(list ,@(mapcar (lambda (dim) (recurse (1- rank
) dim
))
395 ((and (sb!xc
:macro-function
(car data
) env
)
396 (listp (setq expanded
(sb!xc
:macroexpand data env
)))
397 (sequence-constructor-p expanded
))
398 (recurse rank expanded
))
400 ;; This is the important bit: once we are past the level of
401 ;; :INITIAL-CONTENTS that relates to the array structure, reinline LIST
402 ;; and VECTOR so that nested DX isn't screwed up.
403 `(locally (declare (inline list vector
)) ,data
))))
405 ;;; Prevent open coding DIMENSION and :INITIAL-CONTENTS arguments, so that we
406 ;;; can pick them apart in the DEFTRANSFORMS, and transform '(3) style
407 ;;; dimensions to integer args directly.
408 (define-source-transform make-array
(dimensions &rest keyargs
&environment env
)
409 (if (or (and (fun-lexically-notinline-p 'list
)
410 (fun-lexically-notinline-p 'vector
))
411 (oddp (length keyargs
)))
413 (multiple-value-bind (new-dimensions rank
)
414 (flet ((constant-dims (dimensions)
415 (let* ((dims (constant-form-value dimensions env
))
416 (canon (ensure-list dims
))
417 (rank (length canon
)))
418 (values (if (= rank
1)
419 (list 'quote
(car canon
))
422 (cond ((sb!xc
:constantp dimensions env
)
423 (constant-dims dimensions
))
424 ((and (consp dimensions
) (eq 'list dimensions
))
425 (values dimensions
(length (cdr dimensions
))))
427 (values dimensions nil
))))
428 (let ((initial-contents (getf keyargs
:initial-contents
)))
429 (when (and initial-contents rank
)
430 (setf keyargs
(copy-list keyargs
)
431 (getf keyargs
:initial-contents
)
432 (rewrite-initial-contents rank initial-contents env
))))
433 `(locally (declare (notinline list vector
))
434 (make-array ,new-dimensions
,@keyargs
)))))
436 (define-source-transform coerce
(x type
&environment env
)
437 (if (and (sb!xc
:constantp type env
)
439 (memq (car x
) '(sb!impl
::|List| list
440 sb
!impl
::|Vector| vector
)))
441 (let* ((type (constant-form-value type env
))
442 (length (1- (length x
)))
443 ;; Special case, since strings are unions
444 (string-p (member type
'(string simple-string
)))
446 (careful-values-specifier-type type
))))
448 (and (array-type-p ctype
)
449 (csubtypep ctype
(specifier-type '(array * (*))))
450 (proper-list-of-length-p (array-type-dimensions ctype
) 1)
451 (or (eq (car (array-type-dimensions ctype
)) '*)
452 (eq (car (array-type-dimensions ctype
)) length
))))
454 :element-type
',(if string-p
456 (nth-value 1 (simplify-vector-type ctype
)))
457 :initial-contents
,x
)
461 ;;; This baby is a bit of a monster, but it takes care of any MAKE-ARRAY
462 ;;; call which creates a vector with a known element type -- and tries
463 ;;; to do a good job with all the different ways it can happen.
464 (defun transform-make-array-vector (length element-type initial-element
465 initial-contents call
)
466 (aver (or (not element-type
) (constant-lvar-p element-type
)))
467 (let* ((c-length (when (constant-lvar-p length
)
468 (lvar-value length
)))
469 (elt-spec (if element-type
470 (lvar-value element-type
)
472 (elt-ctype (ir1-transform-specifier-type elt-spec
))
473 (saetp (if (unknown-type-p elt-ctype
)
474 (give-up-ir1-transform "~S is an unknown type: ~S"
475 :element-type elt-spec
)
476 (find-saetp-by-ctype elt-ctype
)))
477 (default-initial-element (sb!vm
:saetp-initial-element-default saetp
))
478 (n-bits (sb!vm
:saetp-n-bits saetp
))
479 (typecode (sb!vm
:saetp-typecode saetp
))
480 (n-pad-elements (sb!vm
:saetp-n-pad-elements saetp
))
483 (ceiling (* (+ c-length n-pad-elements
) n-bits
)
485 (let ((padded-length-form (if (zerop n-pad-elements
)
487 `(+ length
,n-pad-elements
))))
490 ((>= n-bits sb
!vm
:n-word-bits
)
491 `(* ,padded-length-form
493 ,(the fixnum
(/ n-bits sb
!vm
:n-word-bits
))))
495 (let ((n-elements-per-word (/ sb
!vm
:n-word-bits n-bits
)))
496 (declare (type index n-elements-per-word
)) ; i.e., not RATIO
497 `(ceiling (truly-the index
,padded-length-form
)
498 ,n-elements-per-word
)))))))
500 `(simple-array ,(sb!vm
:saetp-specifier saetp
) (,(or c-length
'*))))
502 `(truly-the ,result-spec
503 (allocate-vector ,typecode
(the index length
) ,n-words-form
))))
504 (cond ((and initial-element initial-contents
)
505 (abort-ir1-transform "Both ~S and ~S specified."
506 :initial-contents
:initial-element
))
507 ;; :INITIAL-CONTENTS (LIST ...), (VECTOR ...) and `(1 1 ,x) with a
509 ((and initial-contents c-length
510 (lvar-matches initial-contents
511 :fun-names
'(list vector
512 sb
!impl
::|List| sb
!impl
::|Vector|
)
513 :arg-count c-length
))
514 (let ((parameters (eliminate-keyword-args
515 call
1 '((:element-type element-type
)
516 (:initial-contents initial-contents
))))
517 (elt-vars (make-gensym-list c-length
))
518 (lambda-list '(length)))
519 (splice-fun-args initial-contents
:any c-length
)
520 (dolist (p parameters
)
523 (if (eq p
'initial-contents
)
526 `(lambda ,lambda-list
527 (declare (type ,elt-spec
,@elt-vars
)
528 (ignorable ,@lambda-list
))
529 (truly-the ,result-spec
530 (initialize-vector ,alloc-form
,@elt-vars
)))))
531 ;; constant :INITIAL-CONTENTS and LENGTH
532 ((and initial-contents c-length
(constant-lvar-p initial-contents
))
533 (let ((contents (lvar-value initial-contents
)))
534 (unless (= c-length
(length contents
))
535 (abort-ir1-transform "~S has ~S elements, vector length is ~S."
536 :initial-contents
(length contents
) c-length
))
537 (let ((parameters (eliminate-keyword-args
538 call
1 '((:element-type element-type
)
539 (:initial-contents initial-contents
)))))
540 `(lambda (length ,@parameters
)
541 (declare (ignorable ,@parameters
))
542 (truly-the ,result-spec
543 (initialize-vector ,alloc-form
544 ,@(map 'list
(lambda (elt)
545 `(the ,elt-spec
',elt
))
547 ;; any other :INITIAL-CONTENTS
549 (let ((parameters (eliminate-keyword-args
550 call
1 '((:element-type element-type
)
551 (:initial-contents initial-contents
)))))
552 `(lambda (length ,@parameters
)
553 (declare (ignorable ,@parameters
))
554 (unless (= length
(length initial-contents
))
555 (error "~S has ~S elements, vector length is ~S."
556 :initial-contents
(length initial-contents
) length
))
557 (truly-the ,result-spec
558 (replace ,alloc-form initial-contents
)))))
559 ;; :INITIAL-ELEMENT, not EQL to the default
560 ((and initial-element
561 (or (not (constant-lvar-p initial-element
))
562 (not (eql default-initial-element
(lvar-value initial-element
)))))
563 (let ((parameters (eliminate-keyword-args
564 call
1 '((:element-type element-type
)
565 (:initial-element initial-element
))))
566 (init (if (constant-lvar-p initial-element
)
567 (list 'quote
(lvar-value initial-element
))
569 `(lambda (length ,@parameters
)
570 (declare (ignorable ,@parameters
))
571 (truly-the ,result-spec
572 (fill ,alloc-form
(the ,elt-spec
,init
))))))
573 ;; just :ELEMENT-TYPE, or maybe with :INITIAL-ELEMENT EQL to the
577 (and (and (testable-type-p elt-ctype
)
578 (neq elt-ctype
*empty-type
*)
579 (not (ctypep default-initial-element elt-ctype
)))
580 ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE
581 ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If
582 ;; INITIAL-ELEMENT is not supplied, the consequences of later
583 ;; reading an uninitialized element of new-array are undefined,"
584 ;; so this could be legal code as long as the user plans to
585 ;; write before he reads, and if he doesn't we're free to do
586 ;; anything we like. But in case the user doesn't know to write
587 ;; elements before he reads elements (or to read manuals before
588 ;; he writes code:-), we'll signal a STYLE-WARNING in case he
589 ;; didn't realize this.
591 (compiler-warn "~S ~S is not a ~S"
592 :initial-element default-initial-element
594 (compiler-style-warn "The default initial element ~S is not a ~S."
595 default-initial-element
597 (let ((parameters (eliminate-keyword-args
598 call
1 '((:element-type element-type
)
599 (:initial-element initial-element
)))))
600 `(lambda (length ,@parameters
)
601 (declare (ignorable ,@parameters
))
604 ;;; IMPORTANT: The order of these three MAKE-ARRAY forms matters: the least
605 ;;; specific must come first, otherwise suboptimal transforms will result for
608 (deftransform make-array
((dims &key initial-element element-type
609 adjustable fill-pointer
)
612 (delay-ir1-transform node
:constraint
)
613 (let* ((eltype (cond ((not element-type
) t
)
614 ((not (constant-lvar-p element-type
))
615 (give-up-ir1-transform
616 "ELEMENT-TYPE is not constant."))
618 (lvar-value element-type
))))
619 (eltype-type (ir1-transform-specifier-type eltype
))
620 (saetp (if (unknown-type-p eltype-type
)
621 (give-up-ir1-transform
622 "ELEMENT-TYPE ~s is not a known type"
625 sb
!vm
:*specialized-array-element-type-properties
*
626 :key
#'sb
!vm
:saetp-ctype
628 (creation-form `(%make-array
631 (sb!vm
:saetp-typecode saetp
)
632 (give-up-ir1-transform))
633 ,(sb!vm
:saetp-n-bits saetp
)
635 '(:fill-pointer fill-pointer
))
637 '(:adjustable adjustable
)))))
638 (cond ((or (not initial-element
)
639 (and (constant-lvar-p initial-element
)
640 (eql (lvar-value initial-element
)
641 (sb!vm
:saetp-initial-element-default saetp
))))
644 ;; error checking for target, disabled on the host because
645 ;; (CTYPE-OF #\Null) is not possible.
647 (when (constant-lvar-p initial-element
)
648 (let ((value (lvar-value initial-element
)))
650 ((not (ctypep value
(sb!vm
:saetp-ctype saetp
)))
651 ;; this case will cause an error at runtime, so we'd
652 ;; better WARN about it now.
653 (warn 'array-initial-element-mismatch
654 :format-control
"~@<~S is not a ~S (which is the ~
659 (type-specifier (sb!vm
:saetp-ctype saetp
))
660 'upgraded-array-element-type
662 ((not (ctypep value eltype-type
))
663 ;; this case will not cause an error at runtime, but
664 ;; it's still worth STYLE-WARNing about.
665 (compiler-style-warn "~S is not a ~S."
667 `(let ((array ,creation-form
))
668 (multiple-value-bind (vector)
669 (%data-vector-and-index array
0)
670 (fill vector
(the ,(sb!vm
:saetp-specifier saetp
) initial-element
)))
673 ;;; The list type restriction does not ensure that the result will be a
674 ;;; multi-dimensional array. But the lack of adjustable, fill-pointer,
675 ;;; and displaced-to keywords ensures that it will be simple.
677 ;;; FIXME: should we generalize this transform to non-simple (though
678 ;;; non-displaced-to) arrays, given that we have %WITH-ARRAY-DATA to
679 ;;; deal with those? Maybe when the DEFTRANSFORM
680 ;;; %DATA-VECTOR-AND-INDEX in the VECTOR case problem is solved? --
682 (deftransform make-array
((dims &key
683 element-type initial-element initial-contents
)
685 (:element-type
(constant-arg *))
687 (:initial-contents
*))
691 (when (lvar-matches dims
:fun-names
'(list) :arg-count
1)
692 (let ((length (car (splice-fun-args dims
:any
1))))
693 (return-from make-array
694 (transform-make-array-vector length
699 (unless (constant-lvar-p dims
)
700 (give-up-ir1-transform
701 "The dimension list is not constant; cannot open code array creation."))
702 (let ((dims (lvar-value dims
))
703 (element-type-ctype (and (constant-lvar-p element-type
)
704 (ir1-transform-specifier-type
705 (lvar-value element-type
)))))
706 (when (contains-unknown-type-p element-type-ctype
)
707 (give-up-ir1-transform))
708 (unless (every (lambda (x) (typep x
'(integer 0))) dims
)
709 (give-up-ir1-transform
710 "The dimension list contains something other than an integer: ~S"
712 (if (= (length dims
) 1)
713 `(make-array ',(car dims
)
715 '(:element-type element-type
))
716 ,@(when initial-element
717 '(:initial-element initial-element
))
718 ,@(when initial-contents
719 '(:initial-contents initial-contents
)))
720 (let* ((total-size (reduce #'* dims
))
723 ,(cond ((null element-type
) t
)
725 (sb!xc
:upgraded-array-element-type
726 (lvar-value element-type
)))
728 ,(make-list rank
:initial-element
'*))))
729 `(let ((header (make-array-header sb
!vm
:simple-array-widetag
,rank
))
730 (data (make-array ,total-size
732 '(:element-type element-type
))
733 ,@(when initial-element
734 '(:initial-element initial-element
)))))
735 ,@(when initial-contents
736 ;; FIXME: This is could be open coded at least a bit too
737 `((sb!impl
::fill-data-vector data
',dims initial-contents
)))
738 (setf (%array-fill-pointer header
) ,total-size
)
739 (setf (%array-fill-pointer-p header
) nil
)
740 (setf (%array-available-elements header
) ,total-size
)
741 (setf (%array-data-vector header
) data
)
742 (setf (%array-displaced-p header
) nil
)
743 (setf (%array-displaced-from header
) nil
)
745 (mapcar (lambda (dim)
746 `(setf (%array-dimension header
,(incf axis
))
749 (truly-the ,spec header
)))))))
751 (deftransform make-array
((dims &key element-type initial-element initial-contents
)
753 (:element-type
(constant-arg *))
755 (:initial-contents
*))
758 (transform-make-array-vector dims
765 (deftransform adjust-array
((array dims
&key displaced-to displaced-index-offset
)
767 (:displaced-to array
)
768 (:displaced-index-offset
*)))
770 (give-up-ir1-transform))
772 (when (invalid-array-p array
)
773 (invalid-array-error array
))
774 (unless (= 1 (array-rank array
))
775 (error "The number of dimensions is not equal to the rank of the array"))
776 (unless (eql (array-element-type array
) (array-element-type displaced-to
))
777 (error "Can't displace an array of type ~S to another of type ~S"
778 (array-element-type array
) (array-element-type displaced-to
)))
779 (let ((displacement (or displaced-index-offset
0)))
780 (when (< (array-total-size displaced-to
) (+ displacement dims
))
781 (error "The :DISPLACED-TO array is too small"))
782 (if (adjustable-array-p array
)
783 (let ((nfp (when (array-has-fill-pointer-p array
)
784 (when (> (%array-fill-pointer array
) dims
)
785 (error "Cannot ADJUST-ARRAY an array to a size smaller than its fill pointer"))
786 (%array-fill-pointer array
))))
787 (set-array-header array displaced-to dims nfp
788 displacement dims t nil
))
789 (make-array dims
:element-type
(array-element-type array
)
790 :displaced-to displaced-to
791 ,@(and displaced-index-offset
792 '(:displaced-index-offset displacement
)))))))
794 ;;;; miscellaneous properties of arrays
796 ;;; Transforms for various array properties. If the property is know
797 ;;; at compile time because of a type spec, use that constant value.
799 ;;; Most of this logic may end up belonging in code/late-type.lisp;
800 ;;; however, here we also need the -OR-GIVE-UP for the transforms, and
801 ;;; maybe this is just too sloppy for actual type logic. -- CSR,
803 (defun array-type-dimensions-or-give-up (type)
804 (labels ((maybe-array-type-dimensions (type)
807 (array-type-dimensions type
))
809 (let* ((types (loop for type in
(union-type-types type
)
810 for dimensions
= (maybe-array-type-dimensions type
)
811 when
(eq dimensions
'*)
813 (return-from maybe-array-type-dimensions
'*)
817 (length (length result
))
819 (dolist (other (cdr types
))
820 (when (/= length
(length other
))
821 (give-up-ir1-transform
822 "~@<dimensions of arrays in union type ~S do not match~:@>"
823 (type-specifier type
)))
824 (unless (equal result other
)
825 (setf complete-match nil
)))
828 (make-list length
:initial-element
'*))))
830 (let* ((types (remove nil
(mapcar #'maybe-array-type-dimensions
831 (intersection-type-types type
))))
832 (result (car types
)))
833 (dolist (other (cdr types
) result
)
834 (unless (equal result other
)
836 "~@<dimensions of arrays in intersection type ~S do not match~:@>"
837 (type-specifier type
)))))))))
838 (or (maybe-array-type-dimensions type
)
839 (give-up-ir1-transform
840 "~@<don't know how to extract array dimensions from type ~S~:@>"
841 (type-specifier type
)))))
843 (defun conservative-array-type-complexp (type)
845 (array-type (array-type-complexp type
))
847 (let ((types (union-type-types type
)))
848 (aver (> (length types
) 1))
849 (let ((result (conservative-array-type-complexp (car types
))))
850 (dolist (type (cdr types
) result
)
851 (unless (eq (conservative-array-type-complexp type
) result
)
852 (return-from conservative-array-type-complexp
:maybe
))))))
853 ;; FIXME: intersection type
856 ;; Let type derivation handle constant cases. We only do easy strength
858 (deftransform array-rank
((array) (array) * :node node
)
859 (let ((array-type (lvar-type array
)))
860 (cond ((eq t
(and (array-type-p array-type
)
861 (array-type-complexp array-type
)))
862 '(%array-rank array
))
864 (delay-ir1-transform node
:constraint
)
865 `(if (array-header-p array
)
869 (defun derive-array-rank (ctype)
870 (let ((array (specifier-type 'array
)))
872 (cond ((not (types-equal-or-intersect x array
))
873 '()) ; Definitely not an array!
875 (let ((dims (array-type-dimensions x
)))
878 (list (length dims
)))))
881 ;; Might as well catch some easy negation cases.
884 (let ((dims (array-type-dimensions x
)))
887 ((every (lambda (dim)
890 (list (length dims
)))
894 (declare (dynamic-extent #'over
#'under
))
895 (multiple-value-bind (not-p ranks
)
896 (list-abstract-type-function ctype
#'over
:under
#'under
)
897 (cond ((eql ranks
'*)
901 (specifier-type `(not (member ,@ranks
))))
903 (specifier-type `(member ,@ranks
))))))))
905 (defoptimizer (array-rank derive-type
) ((array))
906 (derive-array-rank (lvar-type array
)))
908 (defoptimizer (%array-rank derive-type
) ((array))
909 (derive-array-rank (lvar-type array
)))
911 ;;; If we know the dimensions at compile time, just use it. Otherwise,
912 ;;; if we can tell that the axis is in bounds, convert to
913 ;;; %ARRAY-DIMENSION (which just indirects the array header) or length
914 ;;; (if it's simple and a vector).
915 (deftransform array-dimension
((array axis
)
917 (unless (constant-lvar-p axis
)
918 (give-up-ir1-transform "The axis is not constant."))
919 ;; Dimensions may change thanks to ADJUST-ARRAY, so we need the
920 ;; conservative type.
921 (let ((array-type (lvar-conservative-type array
))
922 (axis (lvar-value axis
)))
923 (let ((dims (array-type-dimensions-or-give-up array-type
)))
925 (give-up-ir1-transform
926 "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime."))
927 (unless (> (length dims
) axis
)
928 (abort-ir1-transform "The array has dimensions ~S, ~W is too large."
931 (let ((dim (nth axis dims
)))
932 (cond ((integerp dim
)
935 (ecase (conservative-array-type-complexp array-type
)
937 '(%array-dimension array
0))
939 '(vector-length array
))
941 `(if (array-header-p array
)
942 (%array-dimension array axis
)
943 (vector-length array
)))))
945 '(%array-dimension array axis
)))))))
947 ;;; If the length has been declared and it's simple, just return it.
948 (deftransform length
((vector)
949 ((simple-array * (*))))
950 (let ((type (lvar-type vector
)))
951 (let ((dims (array-type-dimensions-or-give-up type
)))
952 (unless (and (listp dims
) (integerp (car dims
)))
953 (give-up-ir1-transform
954 "Vector length is unknown, must call LENGTH at runtime."))
957 ;;; All vectors can get their length by using VECTOR-LENGTH. If it's
958 ;;; simple, it will extract the length slot from the vector. It it's
959 ;;; complex, it will extract the fill pointer slot from the array
961 (deftransform length
((vector) (vector))
962 '(vector-length vector
))
964 ;;; If a simple array with known dimensions, then VECTOR-LENGTH is a
965 ;;; compile-time constant.
966 (deftransform vector-length
((vector))
967 (let ((vtype (lvar-type vector
)))
968 (let ((dim (first (array-type-dimensions-or-give-up vtype
))))
970 (give-up-ir1-transform))
971 (when (conservative-array-type-complexp vtype
)
972 (give-up-ir1-transform))
975 ;;; Again, if we can tell the results from the type, just use it.
976 ;;; Otherwise, if we know the rank, convert into a computation based
977 ;;; on array-dimension or %array-available-elements
978 (deftransform array-total-size
((array) (array))
979 (let* ((array-type (lvar-type array
))
980 (dims (array-type-dimensions-or-give-up array-type
)))
982 (give-up-ir1-transform "can't tell the rank at compile time"))
983 (cond ((not (memq '* dims
))
986 ;; A vector, can't use LENGTH since this ignores the fill-pointer
987 `(truly-the index
(array-dimension array
0)))
989 `(%array-available-elements array
)))))
991 ;;; Only complex vectors have fill pointers.
992 (deftransform array-has-fill-pointer-p
((array))
993 (let ((array-type (lvar-type array
)))
994 (let ((dims (array-type-dimensions-or-give-up array-type
)))
995 (if (and (listp dims
) (not (= (length dims
) 1)))
997 (ecase (conservative-array-type-complexp array-type
)
1003 (give-up-ir1-transform
1004 "The array type is ambiguous; must call ~
1005 ARRAY-HAS-FILL-POINTER-P at runtime.")))))))
1007 (deftransform check-bound
((array dimension index
) * * :node node
)
1008 ;; This is simply to avoid multiple evaluation of INDEX by the
1009 ;; translator, it's easier to wrap it in a lambda from DEFTRANSFORM
1010 `(bound-cast array
,(if (constant-lvar-p dimension
)
1011 (lvar-value dimension
)
1015 ;;;; WITH-ARRAY-DATA
1017 ;;; This checks to see whether the array is simple and the start and
1018 ;;; end are in bounds. If so, it proceeds with those values.
1019 ;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that %WITH-ARRAY-DATA
1020 ;;; may be further optimized.
1022 ;;; Given any ARRAY, bind DATA-VAR to the array's data vector and
1023 ;;; START-VAR and END-VAR to the start and end of the designated
1024 ;;; portion of the data vector. SVALUE and EVALUE are any start and
1025 ;;; end specified to the original operation, and are factored into the
1026 ;;; bindings of START-VAR and END-VAR. OFFSET-VAR is the cumulative
1027 ;;; offset of all displacements encountered, and does not include
1030 ;;; When FORCE-INLINE is set, the underlying %WITH-ARRAY-DATA form is
1031 ;;; forced to be inline, overriding the ordinary judgment of the
1032 ;;; %WITH-ARRAY-DATA DEFTRANSFORMs. Ordinarily the DEFTRANSFORMs are
1033 ;;; fairly picky about their arguments, figuring that if you haven't
1034 ;;; bothered to get all your ducks in a row, you probably don't care
1035 ;;; that much about speed anyway! But in some cases it makes sense to
1036 ;;; do type testing inside %WITH-ARRAY-DATA instead of outside, and
1037 ;;; the DEFTRANSFORM can't tell that that's going on, so it can make
1038 ;;; sense to use FORCE-INLINE option in that case.
1039 (sb!xc
:defmacro with-array-data
(((data-var array
&key offset-var
)
1040 (start-var &optional
(svalue 0))
1041 (end-var &optional
(evalue nil
))
1042 &key force-inline check-fill-pointer
1046 (once-only ((n-array array
)
1047 (n-svalue `(the index
,svalue
))
1048 (n-evalue `(the (or index null
) ,evalue
)))
1049 (let ((check-bounds (policy env
(plusp insert-array-bounds-checks
))))
1050 `(multiple-value-bind (,data-var
1053 ,@ (when offset-var
`(,offset-var
)))
1054 (cond ,@(and (not array-header-p
)
1055 `(((not (array-header-p ,n-array
))
1056 (let ((,n-array
,n-array
))
1057 (declare (type (simple-array * (*)) ,n-array
))
1058 ,(once-only ((n-len (if check-fill-pointer
1060 `(array-total-size ,n-array
)))
1061 (n-end `(or ,n-evalue
,n-len
)))
1063 `(if (<= 0 ,n-svalue
,n-end
,n-len
)
1064 (values ,n-array
,n-svalue
,n-end
0)
1065 ,(if check-fill-pointer
1066 `(sequence-bounding-indices-bad-error ,n-array
,n-svalue
,n-evalue
)
1067 `(array-bounding-indices-bad-error ,n-array
,n-svalue
,n-evalue
)))
1068 `(values ,n-array
,n-svalue
,n-end
0)))))))
1070 ,(cond (force-inline
1071 `(%with-array-data-macro
,n-array
,n-svalue
,n-evalue
1072 :check-bounds
,check-bounds
1073 :check-fill-pointer
,check-fill-pointer
1076 `(%with-array-data
/fp
,n-array
,n-svalue
,n-evalue
))
1078 `(%with-array-data
,n-array
,n-svalue
,n-evalue
)))))
1081 ;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in
1082 ;;; DEFTRANSFORMs and DEFUNs.
1083 (sb!xc
:defmacro %with-array-data-macro
1084 (array start end
&key
(element-type '*) check-bounds check-fill-pointer
1086 (with-unique-names (size defaulted-end data cumulative-offset
)
1087 `(let* ((,size
,(cond (check-fill-pointer
1088 `(length (the vector
,array
)))
1090 `(%array-available-elements
,array
))
1092 `(array-total-size ,array
))))
1093 (,defaulted-end
(or ,end
,size
)))
1094 ,@ (when check-bounds
1095 `((unless (<= ,start
,defaulted-end
,size
)
1096 ,(if check-fill-pointer
1097 `(sequence-bounding-indices-bad-error ,array
,start
,end
)
1098 `(array-bounding-indices-bad-error ,array
,start
,end
)))))
1099 (do ((,data
,(if array-header-p
1100 `(%array-data-vector
,array
)
1102 (%array-data-vector
,data
))
1103 (,cumulative-offset
,(if array-header-p
1104 `(%array-displacement
,array
)
1107 (+ ,cumulative-offset
1108 (%array-displacement
,data
)))))
1109 ((not (array-header-p ,data
))
1110 (values (truly-the (simple-array ,element-type
1) ,data
)
1111 (truly-the index
(+ ,cumulative-offset
,start
))
1112 (truly-the index
(+ ,cumulative-offset
,defaulted-end
))
1113 ,cumulative-offset
))))))
1115 (defun transform-%with-array-data
/mumble
(array node check-fill-pointer
)
1116 (let ((element-type (upgraded-element-type-specifier-or-give-up array
))
1117 (type (lvar-type array
))
1118 (check-bounds (policy node
(plusp insert-array-bounds-checks
))))
1119 (if (and (array-type-p type
)
1120 (not (array-type-complexp type
))
1121 (listp (array-type-dimensions type
))
1122 (not (null (cdr (array-type-dimensions type
)))))
1123 ;; If it's a simple multidimensional array, then just return
1124 ;; its data vector directly rather than going through
1125 ;; %WITH-ARRAY-DATA-MACRO. SBCL doesn't generally generate
1126 ;; code that would use this currently, but we have encouraged
1127 ;; users to use WITH-ARRAY-DATA and we may use it ourselves at
1128 ;; some point in the future for optimized libraries or
1131 `(let* ((data (truly-the (simple-array ,element-type
(*))
1132 (%array-data-vector array
)))
1134 (real-end (or end len
)))
1135 (unless (<= 0 start data-end lend
)
1136 (sequence-bounding-indices-bad-error array start end
))
1137 (values data
0 real-end
0))
1138 `(let ((data (truly-the (simple-array ,element-type
(*))
1139 (%array-data-vector array
))))
1140 (values data
0 (or end
(length data
)) 0)))
1141 `(%with-array-data-macro array start end
1142 :check-fill-pointer
,check-fill-pointer
1143 :check-bounds
,check-bounds
1144 :element-type
,element-type
))))
1146 ;; It might very well be reasonable to allow general ARRAY here, I
1147 ;; just haven't tried to understand the performance issues involved.
1148 ;; -- WHN, and also CSR 2002-05-26
1149 (deftransform %with-array-data
((array start end
)
1150 ((or vector simple-array
) index
(or index null
) t
)
1153 :policy
(> speed space
))
1154 "inline non-SIMPLE-vector-handling logic"
1155 (transform-%with-array-data
/mumble array node nil
))
1156 (deftransform %with-array-data
/fp
((array start end
)
1157 ((or vector simple-array
) index
(or index null
) t
)
1160 :policy
(> speed space
))
1161 "inline non-SIMPLE-vector-handling logic"
1162 (transform-%with-array-data
/mumble array node t
))
1164 ;;;; array accessors
1166 ;;; We convert all typed array accessors into AREF and (SETF AREF) with type
1167 ;;; assertions on the array.
1168 (macrolet ((define-bit-frob (reffer simplep
)
1170 (define-source-transform ,reffer
(a &rest i
)
1171 `(aref (the (,',(if simplep
'simple-array
'array
)
1173 ,(mapcar (constantly '*) i
))
1175 (define-source-transform (setf ,reffer
) (value a
&rest i
)
1176 `(setf (aref (the (,',(if simplep
'simple-array
'array
)
1178 ,(mapcar (constantly '*) i
))
1181 (define-bit-frob sbit t
)
1182 (define-bit-frob bit nil
))
1184 (macrolet ((define-frob (reffer setter type
)
1186 (define-source-transform ,reffer
(a i
)
1187 `(aref (the ,',type
,a
) ,i
))
1188 (define-source-transform ,setter
(a i v
)
1189 `(setf (aref (the ,',type
,a
) ,i
) ,v
)))))
1190 (define-frob schar %scharset simple-string
)
1191 (define-frob char %charset string
))
1193 ;;; We transform SVREF and %SVSET directly into DATA-VECTOR-REF/SET: this is
1194 ;;; around 100 times faster than going through the general-purpose AREF
1195 ;;; transform which ends up doing a lot of work -- and introducing many
1196 ;;; intermediate lambdas, each meaning a new trip through the compiler -- to
1197 ;;; get the same result.
1199 ;;; FIXME: [S]CHAR, and [S]BIT above would almost certainly benefit from a similar
1201 (define-source-transform svref
(vector index
)
1202 (let ((elt-type (or (when (symbolp vector
)
1203 (let ((var (lexenv-find vector vars
)))
1204 (when (lambda-var-p var
)
1206 (array-type-declared-element-type (lambda-var-type var
))))))
1208 (with-unique-names (n-vector)
1209 `(let ((,n-vector
,vector
))
1210 (the ,elt-type
(data-vector-ref
1211 (the simple-vector
,n-vector
)
1212 (check-bound ,n-vector
(length ,n-vector
) ,index
)))))))
1214 (define-source-transform %svset
(vector index value
)
1215 (let ((elt-type (or (when (symbolp vector
)
1216 (let ((var (lexenv-find vector vars
)))
1217 (when (lambda-var-p var
)
1219 (array-type-declared-element-type (lambda-var-type var
))))))
1221 (with-unique-names (n-vector)
1222 `(let ((,n-vector
,vector
))
1223 (truly-the ,elt-type
(data-vector-set
1224 (the simple-vector
,n-vector
)
1225 (check-bound ,n-vector
(length ,n-vector
) ,index
)
1226 (the ,elt-type
,value
)))))))
1228 (macrolet (;; This is a handy macro for computing the row-major index
1229 ;; given a set of indices. We wrap each index with a call
1230 ;; to CHECK-BOUND to ensure that everything works out
1231 ;; correctly. We can wrap all the interior arithmetic with
1232 ;; TRULY-THE INDEX because we know the resultant
1233 ;; row-major index must be an index.
1234 (with-row-major-index ((array indices index
&optional new-value
)
1236 `(let (n-indices dims
)
1237 (dotimes (i (length ,indices
))
1238 (push (make-symbol (format nil
"INDEX-~D" i
)) n-indices
)
1239 (push (make-symbol (format nil
"DIM-~D" i
)) dims
))
1240 (setf n-indices
(nreverse n-indices
))
1241 (setf dims
(nreverse dims
))
1242 `(lambda (,@',(when new-value
(list new-value
))
1243 ,',array
,@n-indices
)
1244 (declare (ignorable ,',array
))
1245 (let* (,@(let ((,index -
1))
1246 (mapcar (lambda (name)
1247 `(,name
(array-dimension
1254 (do* ((dims dims
(cdr dims
))
1255 (indices n-indices
(cdr indices
))
1256 (last-dim nil
(car dims
))
1257 (form `(check-bound ,',array
1269 ((null (cdr dims
)) form
)))))
1272 ;; Just return the index after computing it.
1273 (deftransform array-row-major-index
((array &rest indices
))
1274 (with-row-major-index (array indices index
)
1277 ;; Convert AREF and (SETF AREF) into a HAIRY-DATA-VECTOR-REF (or
1278 ;; HAIRY-DATA-VECTOR-SET) with the set of indices replaced with the an
1279 ;; expression for the row major index.
1280 (deftransform aref
((array &rest indices
))
1281 (with-row-major-index (array indices index
)
1282 (hairy-data-vector-ref array index
)))
1284 (deftransform (setf aref
) ((new-value array
&rest subscripts
))
1285 (with-row-major-index (array subscripts index new-value
)
1286 (hairy-data-vector-set array index new-value
))))
1288 ;; For AREF of vectors we do the bounds checking in the callee. This
1289 ;; lets us do a significantly more efficient check for simple-arrays
1290 ;; without bloating the code. If we already know the type of the array
1291 ;; with sufficient precision, skip directly to DATA-VECTOR-REF.
1292 (deftransform aref
((array index
) (t t
) * :node node
)
1293 (let* ((type (lvar-type array
))
1294 (element-ctype (array-type-upgraded-element-type type
)))
1296 ((eq element-ctype
*empty-type
*)
1297 `(data-nil-vector-ref array index
))
1298 ((and (array-type-p type
)
1299 (null (array-type-complexp type
))
1300 (neq element-ctype
*wild-type
*)
1301 (eql (length (array-type-dimensions type
)) 1))
1302 (let* ((declared-element-ctype (array-type-declared-element-type type
))
1304 `(data-vector-ref array
1305 (check-bound array
(array-dimension array
0) index
))))
1306 (if (type= declared-element-ctype element-ctype
)
1308 `(the ,(type-specifier declared-element-ctype
) ,bare-form
))))
1309 ((policy node
(zerop insert-array-bounds-checks
))
1310 `(hairy-data-vector-ref array index
))
1311 (t `(hairy-data-vector-ref/check-bounds array index
)))))
1313 (deftransform (setf aref
) ((new-value array index
) (t t t
) * :node node
)
1314 (if (policy node
(zerop insert-array-bounds-checks
))
1315 `(hairy-data-vector-set array index new-value
)
1316 `(hairy-data-vector-set/check-bounds array index new-value
)))
1318 ;;; But if we find out later that there's some useful type information
1319 ;;; available, switch back to the normal one to give other transforms
1321 (macrolet ((define (name transform-to extra extra-type
)
1322 (declare (ignore extra-type
))
1323 `(deftransform ,name
((array index
,@extra
))
1324 (let* ((type (lvar-type array
))
1325 (element-type (array-type-upgraded-element-type type
))
1326 (declared-type (type-specifier
1327 (array-type-declared-element-type type
))))
1328 ;; If an element type has been declared, we want to
1329 ;; use that information it for type checking (even
1330 ;; if the access can't be optimized due to the array
1331 ;; not being simple).
1332 (when (and (eq element-type
*wild-type
*)
1333 ;; This type logic corresponds to the special
1334 ;; case for strings in HAIRY-DATA-VECTOR-REF
1335 ;; (generic/vm-tran.lisp)
1336 (not (csubtypep type
(specifier-type 'simple-string
))))
1337 (when (or (not (array-type-p type
))
1338 ;; If it's a simple array, we might be able
1339 ;; to inline the access completely.
1340 (not (null (array-type-complexp type
))))
1341 (give-up-ir1-transform
1342 "Upgraded element type of array is not known at compile time.")))
1344 ``(truly-the ,declared-type
1345 (,',transform-to array
1347 (array-dimension array
0)
1349 (the ,declared-type
,@',extra
)))
1350 ``(the ,declared-type
1351 (,',transform-to array
1353 (array-dimension array
0)
1355 (define hairy-data-vector-ref
/check-bounds
1356 hairy-data-vector-ref nil nil
)
1357 (define hairy-data-vector-set
/check-bounds
1358 hairy-data-vector-set
(new-value) (*)))
1360 ;;; Just convert into a HAIRY-DATA-VECTOR-REF (or
1361 ;;; HAIRY-DATA-VECTOR-SET) after checking that the index is inside the
1362 ;;; array total size.
1363 (deftransform row-major-aref
((array index
))
1364 `(hairy-data-vector-ref array
1365 (check-bound array
(array-total-size array
) index
)))
1366 (deftransform %set-row-major-aref
((array index new-value
))
1367 `(hairy-data-vector-set array
1368 (check-bound array
(array-total-size array
) index
)
1371 ;;;; bit-vector array operation canonicalization
1373 ;;;; We convert all bit-vector operations to have the result array
1374 ;;;; specified. This allows any result allocation to be open-coded,
1375 ;;;; and eliminates the need for any VM-dependent transforms to handle
1378 (macrolet ((def (fun)
1380 (deftransform ,fun
((bit-array-1 bit-array-2
1381 &optional result-bit-array
)
1382 (bit-vector bit-vector
&optional null
) *
1383 :policy
(>= speed space
))
1384 `(,',fun bit-array-1 bit-array-2
1385 (make-array (array-dimension bit-array-1
0) :element-type
'bit
)))
1386 ;; If result is T, make it the first arg.
1387 (deftransform ,fun
((bit-array-1 bit-array-2 result-bit-array
)
1388 (bit-vector bit-vector
(eql t
)) *)
1389 `(,',fun bit-array-1 bit-array-2 bit-array-1
)))))
1401 ;;; Similar for BIT-NOT, but there is only one arg...
1402 (deftransform bit-not
((bit-array-1 &optional result-bit-array
)
1403 (bit-vector &optional null
) *
1404 :policy
(>= speed space
))
1405 '(bit-not bit-array-1
1406 (make-array (array-dimension bit-array-1
0) :element-type
'bit
)))
1407 (deftransform bit-not
((bit-array-1 result-bit-array
)
1408 (bit-vector (eql t
)))
1409 '(bit-not bit-array-1 bit-array-1
))
1411 ;;; Pick off some constant cases.
1412 (defoptimizer (array-header-p derive-type
) ((array))
1413 (let ((type (lvar-type array
)))
1414 (cond ((not (array-type-p type
))
1415 ;; FIXME: use analogue of ARRAY-TYPE-DIMENSIONS-OR-GIVE-UP
1418 (let ((dims (array-type-dimensions type
)))
1419 (cond ((csubtypep type
(specifier-type '(simple-array * (*))))
1421 (specifier-type 'null
))
1422 ((and (listp dims
) (/= (length dims
) 1))
1423 ;; multi-dimensional array, will have a header
1424 (specifier-type '(eql t
)))
1425 ((eql (array-type-complexp type
) t
)
1426 (specifier-type '(eql t
)))
