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
764 ;;;; miscellaneous properties of arrays
766 ;;; Transforms for various array properties. If the property is know
767 ;;; at compile time because of a type spec, use that constant value.
769 ;;; Most of this logic may end up belonging in code/late-type.lisp;
770 ;;; however, here we also need the -OR-GIVE-UP for the transforms, and
771 ;;; maybe this is just too sloppy for actual type logic. -- CSR,
773 (defun array-type-dimensions-or-give-up (type)
774 (labels ((maybe-array-type-dimensions (type)
777 (array-type-dimensions type
))
779 (let* ((types (remove nil
(mapcar #'maybe-array-type-dimensions
780 (union-type-types type
))))
782 (length (length result
))
784 (dolist (other (cdr types
))
785 (when (/= length
(length other
))
786 (give-up-ir1-transform
787 "~@<dimensions of arrays in union type ~S do not match~:@>"
788 (type-specifier type
)))
789 (unless (equal result other
)
790 (setf complete-match nil
)))
793 (make-list length
:initial-element
'*))))
795 (let* ((types (remove nil
(mapcar #'maybe-array-type-dimensions
796 (intersection-type-types type
))))
797 (result (car types
)))
798 (dolist (other (cdr types
) result
)
799 (unless (equal result other
)
801 "~@<dimensions of arrays in intersection type ~S do not match~:@>"
802 (type-specifier type
)))))))))
803 (or (maybe-array-type-dimensions type
)
804 (give-up-ir1-transform
805 "~@<don't know how to extract array dimensions from type ~S~:@>"
806 (type-specifier type
)))))
808 (defun conservative-array-type-complexp (type)
810 (array-type (array-type-complexp type
))
812 (let ((types (union-type-types type
)))
813 (aver (> (length types
) 1))
814 (let ((result (conservative-array-type-complexp (car types
))))
815 (dolist (type (cdr types
) result
)
816 (unless (eq (conservative-array-type-complexp type
) result
)
817 (return-from conservative-array-type-complexp
:maybe
))))))
818 ;; FIXME: intersection type
821 ;; Let type derivation handle constant cases. We only do easy strength
823 (deftransform array-rank
((array) (array) * :node node
)
824 (let ((array-type (lvar-type array
)))
825 (cond ((eq t
(and (array-type-p array-type
)
826 (array-type-complexp array-type
)))
827 '(%array-rank array
))
829 (delay-ir1-transform node
:constraint
)
830 `(if (array-header-p array
)
834 (defun derive-array-rank (ctype)
835 (let ((array (specifier-type 'array
)))
837 (cond ((not (types-equal-or-intersect x array
))
838 '()) ; Definitely not an array!
840 (let ((dims (array-type-dimensions x
)))
843 (list (length dims
)))))
846 ;; Might as well catch some easy negation cases.
849 (let ((dims (array-type-dimensions x
)))
852 ((every (lambda (dim)
855 (list (length dims
)))
859 (declare (dynamic-extent #'over
#'under
))
860 (multiple-value-bind (not-p ranks
)
861 (list-abstract-type-function ctype
#'over
:under
#'under
)
862 (cond ((eql ranks
'*)
866 (specifier-type `(not (member ,@ranks
))))
868 (specifier-type `(member ,@ranks
))))))))
870 (defoptimizer (array-rank derive-type
) ((array))
871 (derive-array-rank (lvar-type array
)))
873 (defoptimizer (%array-rank derive-type
) ((array))
874 (derive-array-rank (lvar-type array
)))
876 ;;; If we know the dimensions at compile time, just use it. Otherwise,
877 ;;; if we can tell that the axis is in bounds, convert to
878 ;;; %ARRAY-DIMENSION (which just indirects the array header) or length
879 ;;; (if it's simple and a vector).
880 (deftransform array-dimension
((array axis
)
882 (unless (constant-lvar-p axis
)
883 (give-up-ir1-transform "The axis is not constant."))
884 ;; Dimensions may change thanks to ADJUST-ARRAY, so we need the
885 ;; conservative type.
886 (let ((array-type (lvar-conservative-type array
))
887 (axis (lvar-value axis
)))
888 (let ((dims (array-type-dimensions-or-give-up array-type
)))
890 (give-up-ir1-transform
891 "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime."))
892 (unless (> (length dims
) axis
)
893 (abort-ir1-transform "The array has dimensions ~S, ~W is too large."
896 (let ((dim (nth axis dims
)))
897 (cond ((integerp dim
)
900 (ecase (conservative-array-type-complexp array-type
)
902 '(%array-dimension array
0))
904 '(vector-length array
))
906 `(if (array-header-p array
)
907 (%array-dimension array axis
)
908 (vector-length array
)))))
910 '(%array-dimension array axis
)))))))
912 ;;; If the length has been declared and it's simple, just return it.
913 (deftransform length
((vector)
914 ((simple-array * (*))))
915 (let ((type (lvar-type vector
)))
916 (let ((dims (array-type-dimensions-or-give-up type
)))
917 (unless (and (listp dims
) (integerp (car dims
)))
918 (give-up-ir1-transform
919 "Vector length is unknown, must call LENGTH at runtime."))
922 ;;; All vectors can get their length by using VECTOR-LENGTH. If it's
923 ;;; simple, it will extract the length slot from the vector. It it's
924 ;;; complex, it will extract the fill pointer slot from the array
926 (deftransform length
((vector) (vector))
927 '(vector-length vector
))
929 ;;; If a simple array with known dimensions, then VECTOR-LENGTH is a
930 ;;; compile-time constant.
931 (deftransform vector-length
((vector))
932 (let ((vtype (lvar-type vector
)))
933 (let ((dim (first (array-type-dimensions-or-give-up vtype
))))
935 (give-up-ir1-transform))
936 (when (conservative-array-type-complexp vtype
)
937 (give-up-ir1-transform))
940 ;;; Again, if we can tell the results from the type, just use it.
941 ;;; Otherwise, if we know the rank, convert into a computation based
942 ;;; on array-dimension. We can wrap a TRULY-THE INDEX around the
943 ;;; multiplications because we know that the total size must be an
945 (deftransform array-total-size
((array)
947 (let ((array-type (lvar-type array
)))
948 (let ((dims (array-type-dimensions-or-give-up array-type
)))
950 (give-up-ir1-transform "can't tell the rank at compile time"))
952 (do ((form 1 `(truly-the index
953 (* (array-dimension array
,i
) ,form
)))
955 ((= i
(length dims
)) form
))
956 (reduce #'* dims
)))))
958 ;;; Only complex vectors have fill pointers.
959 (deftransform array-has-fill-pointer-p
((array))
960 (let ((array-type (lvar-type array
)))
961 (let ((dims (array-type-dimensions-or-give-up array-type
)))
962 (if (and (listp dims
) (not (= (length dims
) 1)))
964 (ecase (conservative-array-type-complexp array-type
)
970 (give-up-ir1-transform
971 "The array type is ambiguous; must call ~
972 ARRAY-HAS-FILL-POINTER-P at runtime.")))))))
974 (deftransform check-bound
((array dimension index
) * * :node node
)
975 ;; This is simply to avoid multiple evaluation of INDEX by the
976 ;; translator, it's easier to wrap it in a lambda from DEFTRANSFORM
977 `(bound-cast array dimension index
))
981 ;;; This checks to see whether the array is simple and the start and
982 ;;; end are in bounds. If so, it proceeds with those values.
983 ;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that %WITH-ARRAY-DATA
984 ;;; may be further optimized.
986 ;;; Given any ARRAY, bind DATA-VAR to the array's data vector and
987 ;;; START-VAR and END-VAR to the start and end of the designated
988 ;;; portion of the data vector. SVALUE and EVALUE are any start and
989 ;;; end specified to the original operation, and are factored into the
990 ;;; bindings of START-VAR and END-VAR. OFFSET-VAR is the cumulative
991 ;;; offset of all displacements encountered, and does not include
994 ;;; When FORCE-INLINE is set, the underlying %WITH-ARRAY-DATA form is
995 ;;; forced to be inline, overriding the ordinary judgment of the
996 ;;; %WITH-ARRAY-DATA DEFTRANSFORMs. Ordinarily the DEFTRANSFORMs are
997 ;;; fairly picky about their arguments, figuring that if you haven't
998 ;;; bothered to get all your ducks in a row, you probably don't care
999 ;;; that much about speed anyway! But in some cases it makes sense to
1000 ;;; do type testing inside %WITH-ARRAY-DATA instead of outside, and
1001 ;;; the DEFTRANSFORM can't tell that that's going on, so it can make
1002 ;;; sense to use FORCE-INLINE option in that case.
1003 (sb!xc
:defmacro with-array-data
(((data-var array
&key offset-var
)
1004 (start-var &optional
(svalue 0))
1005 (end-var &optional
(evalue nil
))
1006 &key force-inline check-fill-pointer
)
1009 (once-only ((n-array array
)
1010 (n-svalue `(the index
,svalue
))
1011 (n-evalue `(the (or index null
) ,evalue
)))
1012 (let ((check-bounds (policy env
(plusp insert-array-bounds-checks
))))
1013 `(multiple-value-bind (,data-var
1016 ,@(when offset-var
`(,offset-var
)))
1017 (if (not (array-header-p ,n-array
))
1018 (let ((,n-array
,n-array
))
1019 (declare (type (simple-array * (*)) ,n-array
))
1020 ,(once-only ((n-len (if check-fill-pointer
1022 `(array-total-size ,n-array
)))
1023 (n-end `(or ,n-evalue
,n-len
)))
1025 `(if (<= 0 ,n-svalue
,n-end
,n-len
)
1026 (values ,n-array
,n-svalue
,n-end
0)
1027 ,(if check-fill-pointer
1028 `(sequence-bounding-indices-bad-error ,n-array
,n-svalue
,n-evalue
)
1029 `(array-bounding-indices-bad-error ,n-array
,n-svalue
,n-evalue
)))
1030 `(values ,n-array
,n-svalue
,n-end
0))))
1032 `(%with-array-data-macro
,n-array
,n-svalue
,n-evalue
1033 :check-bounds
,check-bounds
1034 :check-fill-pointer
,check-fill-pointer
)
1035 (if check-fill-pointer
1036 `(%with-array-data
/fp
,n-array
,n-svalue
,n-evalue
)
1037 `(%with-array-data
,n-array
,n-svalue
,n-evalue
))))
1040 ;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in
1041 ;;; DEFTRANSFORMs and DEFUNs.
1042 (def!macro %with-array-data-macro
(array
1049 (with-unique-names (size defaulted-end data cumulative-offset
)
1050 `(let* ((,size
,(if check-fill-pointer
1052 `(array-total-size ,array
)))
1053 (,defaulted-end
(or ,end
,size
)))
1054 ,@(when check-bounds
1055 `((unless (<= ,start
,defaulted-end
,size
)
1056 ,(if check-fill-pointer
1057 `(sequence-bounding-indices-bad-error ,array
,start
,end
)
1058 `(array-bounding-indices-bad-error ,array
,start
,end
)))))
1059 (do ((,data
,array
(%array-data-vector
,data
))
1060 (,cumulative-offset
0
1061 (+ ,cumulative-offset
1062 (%array-displacement
,data
))))
1063 ((not (array-header-p ,data
))
1064 (values (the (simple-array ,element-type
1) ,data
)
1065 (the index
(+ ,cumulative-offset
,start
))
1066 (the index
(+ ,cumulative-offset
,defaulted-end
))
1067 (the index
,cumulative-offset
)))
1068 (declare (type index
,cumulative-offset
))))))
1070 (defun transform-%with-array-data
/mumble
(array node check-fill-pointer
)
1071 (let ((element-type (upgraded-element-type-specifier-or-give-up array
))
1072 (type (lvar-type array
))
1073 (check-bounds (policy node
(plusp insert-array-bounds-checks
))))
1074 (if (and (array-type-p type
)
1075 (not (array-type-complexp type
))
1076 (listp (array-type-dimensions type
))
1077 (not (null (cdr (array-type-dimensions type
)))))
1078 ;; If it's a simple multidimensional array, then just return
1079 ;; its data vector directly rather than going through
1080 ;; %WITH-ARRAY-DATA-MACRO. SBCL doesn't generally generate
1081 ;; code that would use this currently, but we have encouraged
1082 ;; users to use WITH-ARRAY-DATA and we may use it ourselves at
1083 ;; some point in the future for optimized libraries or
1086 `(let* ((data (truly-the (simple-array ,element-type
(*))
1087 (%array-data-vector array
)))
1089 (real-end (or end len
)))
1090 (unless (<= 0 start data-end lend
)
1091 (sequence-bounding-indices-bad-error array start end
))
1092 (values data
0 real-end
0))
1093 `(let ((data (truly-the (simple-array ,element-type
(*))
1094 (%array-data-vector array
))))
1095 (values data
0 (or end
(length data
)) 0)))
1096 `(%with-array-data-macro array start end
1097 :check-fill-pointer
,check-fill-pointer
1098 :check-bounds
,check-bounds
1099 :element-type
,element-type
))))
1101 ;; It might very well be reasonable to allow general ARRAY here, I
1102 ;; just haven't tried to understand the performance issues involved.
1103 ;; -- WHN, and also CSR 2002-05-26
1104 (deftransform %with-array-data
((array start end
)
1105 ((or vector simple-array
) index
(or index null
) t
)
1108 :policy
(> speed space
))
1109 "inline non-SIMPLE-vector-handling logic"
1110 (transform-%with-array-data
/mumble array node nil
))
1111 (deftransform %with-array-data
/fp
((array start end
)
1112 ((or vector simple-array
) index
(or index null
) t
)
1115 :policy
(> speed space
))
1116 "inline non-SIMPLE-vector-handling logic"
1117 (transform-%with-array-data
/mumble array node t
))
1119 ;;;; array accessors
1121 ;;; We convert all typed array accessors into AREF and (SETF AREF) with type
1122 ;;; assertions on the array.
1123 (macrolet ((define-bit-frob (reffer simplep
)
1125 (define-source-transform ,reffer
(a &rest i
)
1126 `(aref (the (,',(if simplep
'simple-array
'array
)
1128 ,(mapcar (constantly '*) i
))
1130 (define-source-transform (setf ,reffer
) (value a
&rest i
)
1131 `(setf (aref (the (,',(if simplep
'simple-array
'array
)
1133 ,(mapcar (constantly '*) i
))
1136 (define-bit-frob sbit t
)
1137 (define-bit-frob bit nil
))
1139 (macrolet ((define-frob (reffer setter type
)
1141 (define-source-transform ,reffer
(a i
)
1142 `(aref (the ,',type
,a
) ,i
))
1143 (define-source-transform ,setter
(a i v
)
1144 `(setf (aref (the ,',type
,a
) ,i
) ,v
)))))
1145 (define-frob schar %scharset simple-string
)
1146 (define-frob char %charset string
))
1148 ;;; We transform SVREF and %SVSET directly into DATA-VECTOR-REF/SET: this is
1149 ;;; around 100 times faster than going through the general-purpose AREF
1150 ;;; transform which ends up doing a lot of work -- and introducing many
1151 ;;; intermediate lambdas, each meaning a new trip through the compiler -- to
1152 ;;; get the same result.
1154 ;;; FIXME: [S]CHAR, and [S]BIT above would almost certainly benefit from a similar
1156 (define-source-transform svref
(vector index
)
1157 (let ((elt-type (or (when (symbolp vector
)
1158 (let ((var (lexenv-find vector vars
)))
1159 (when (lambda-var-p var
)
1161 (array-type-declared-element-type (lambda-var-type var
))))))
1163 (with-unique-names (n-vector)
1164 `(let ((,n-vector
,vector
))
1165 (the ,elt-type
(data-vector-ref
1166 (the simple-vector
,n-vector
)
1167 (check-bound ,n-vector
(length ,n-vector
) ,index
)))))))
1169 (define-source-transform %svset
(vector index value
)
1170 (let ((elt-type (or (when (symbolp vector
)
1171 (let ((var (lexenv-find vector vars
)))
1172 (when (lambda-var-p var
)
1174 (array-type-declared-element-type (lambda-var-type var
))))))
1176 (with-unique-names (n-vector)
1177 `(let ((,n-vector
,vector
))
1178 (truly-the ,elt-type
(data-vector-set
1179 (the simple-vector
,n-vector
)
1180 (check-bound ,n-vector
(length ,n-vector
) ,index
)
1181 (the ,elt-type
,value
)))))))
1183 (macrolet (;; This is a handy macro for computing the row-major index
1184 ;; given a set of indices. We wrap each index with a call
1185 ;; to CHECK-BOUND to ensure that everything works out
1186 ;; correctly. We can wrap all the interior arithmetic with
1187 ;; TRULY-THE INDEX because we know the resultant
1188 ;; row-major index must be an index.
1189 (with-row-major-index ((array indices index
&optional new-value
)
1191 `(let (n-indices dims
)
1192 (dotimes (i (length ,indices
))
1193 (push (make-symbol (format nil
"INDEX-~D" i
)) n-indices
)
1194 (push (make-symbol (format nil
"DIM-~D" i
)) dims
))
1195 (setf n-indices
(nreverse n-indices
))
1196 (setf dims
(nreverse dims
))
1197 `(lambda (,@',(when new-value
(list new-value
))
1198 ,',array
,@n-indices
)
1199 (declare (ignorable ,',array
))
1200 (let* (,@(let ((,index -
1))
1201 (mapcar (lambda (name)
1202 `(,name
(array-dimension
1209 (do* ((dims dims
(cdr dims
))
1210 (indices n-indices
(cdr indices
))
1211 (last-dim nil
(car dims
))
1212 (form `(check-bound ,',array
1224 ((null (cdr dims
)) form
)))))
1227 ;; Just return the index after computing it.
1228 (deftransform array-row-major-index
((array &rest indices
))
1229 (with-row-major-index (array indices index
)
1232 ;; Convert AREF and (SETF AREF) into a HAIRY-DATA-VECTOR-REF (or
1233 ;; HAIRY-DATA-VECTOR-SET) with the set of indices replaced with the an
1234 ;; expression for the row major index.
1235 (deftransform aref
((array &rest indices
))
1236 (with-row-major-index (array indices index
)
1237 (hairy-data-vector-ref array index
)))
1239 (deftransform (setf aref
) ((new-value array
&rest subscripts
))
1240 (with-row-major-index (array subscripts index new-value
)
1241 (hairy-data-vector-set array index new-value
))))
1243 ;; For AREF of vectors we do the bounds checking in the callee. This
1244 ;; lets us do a significantly more efficient check for simple-arrays
1245 ;; without bloating the code. If we already know the type of the array
1246 ;; with sufficient precision, skip directly to DATA-VECTOR-REF.
1247 (deftransform aref
((array index
) (t t
) * :node node
)
1248 (let* ((type (lvar-type array
))
1249 (element-ctype (array-type-upgraded-element-type type
)))
1251 ((eq element-ctype
*empty-type
*)
1252 `(data-nil-vector-ref array index
))
1253 ((and (array-type-p type
)
1254 (null (array-type-complexp type
))
1255 (neq element-ctype
*wild-type
*)
1256 (eql (length (array-type-dimensions type
)) 1))
1257 (let* ((declared-element-ctype (array-type-declared-element-type type
))
1259 `(data-vector-ref array
1260 (check-bound array
(array-dimension array
0) index
))))
1261 (if (type= declared-element-ctype element-ctype
)
1263 `(the ,(type-specifier declared-element-ctype
) ,bare-form
))))
1264 ((policy node
(zerop insert-array-bounds-checks
))
1265 `(hairy-data-vector-ref array index
))
1266 (t `(hairy-data-vector-ref/check-bounds array index
)))))
1268 (deftransform (setf aref
) ((new-value array index
) (t t t
) * :node node
)
1269 (if (policy node
(zerop insert-array-bounds-checks
))
1270 `(hairy-data-vector-set array index new-value
)
1271 `(hairy-data-vector-set/check-bounds array index new-value
)))
1273 ;;; But if we find out later that there's some useful type information
1274 ;;; available, switch back to the normal one to give other transforms
1276 (macrolet ((define (name transform-to extra extra-type
)
1277 (declare (ignore extra-type
))
1278 `(deftransform ,name
((array index
,@extra
))
1279 (let* ((type (lvar-type array
))
1280 (element-type (array-type-upgraded-element-type type
))
1281 (declared-type (type-specifier
1282 (array-type-declared-element-type type
))))
1283 ;; If an element type has been declared, we want to
1284 ;; use that information it for type checking (even
1285 ;; if the access can't be optimized due to the array
1286 ;; not being simple).
1287 (when (and (eq element-type
*wild-type
*)
1288 ;; This type logic corresponds to the special
1289 ;; case for strings in HAIRY-DATA-VECTOR-REF
1290 ;; (generic/vm-tran.lisp)
1291 (not (csubtypep type
(specifier-type 'simple-string
))))
1292 (when (or (not (array-type-p type
))
1293 ;; If it's a simple array, we might be able
1294 ;; to inline the access completely.
1295 (not (null (array-type-complexp type
))))
1296 (give-up-ir1-transform
1297 "Upgraded element type of array is not known at compile time.")))
1299 ``(truly-the ,declared-type
1300 (,',transform-to array
1302 (array-dimension array
0)
1304 (the ,declared-type
,@',extra
)))
1305 ``(the ,declared-type
1306 (,',transform-to array
1308 (array-dimension array
0)
1310 (define hairy-data-vector-ref
/check-bounds
1311 hairy-data-vector-ref nil nil
)
1312 (define hairy-data-vector-set
/check-bounds
1313 hairy-data-vector-set
(new-value) (*)))
1315 ;;; Just convert into a HAIRY-DATA-VECTOR-REF (or
1316 ;;; HAIRY-DATA-VECTOR-SET) after checking that the index is inside the
1317 ;;; array total size.
1318 (deftransform row-major-aref
((array index
))
1319 `(hairy-data-vector-ref array
1320 (check-bound array
(array-total-size array
) index
)))
1321 (deftransform %set-row-major-aref
((array index new-value
))
1322 `(hairy-data-vector-set array
1323 (check-bound array
(array-total-size array
) index
)
1326 ;;;; bit-vector array operation canonicalization
1328 ;;;; We convert all bit-vector operations to have the result array
1329 ;;;; specified. This allows any result allocation to be open-coded,
1330 ;;;; and eliminates the need for any VM-dependent transforms to handle
1333 (macrolet ((def (fun)
1335 (deftransform ,fun
((bit-array-1 bit-array-2
1336 &optional result-bit-array
)
1337 (bit-vector bit-vector
&optional null
) *
1338 :policy
(>= speed space
))
1339 `(,',fun bit-array-1 bit-array-2
1340 (make-array (array-dimension bit-array-1
0) :element-type
'bit
)))
1341 ;; If result is T, make it the first arg.
1342 (deftransform ,fun
((bit-array-1 bit-array-2 result-bit-array
)
1343 (bit-vector bit-vector
(eql t
)) *)
1344 `(,',fun bit-array-1 bit-array-2 bit-array-1
)))))
1356 ;;; Similar for BIT-NOT, but there is only one arg...
1357 (deftransform bit-not
((bit-array-1 &optional result-bit-array
)
1358 (bit-vector &optional null
) *
1359 :policy
(>= speed space
))
1360 '(bit-not bit-array-1
1361 (make-array (array-dimension bit-array-1
0) :element-type
'bit
)))
1362 (deftransform bit-not
((bit-array-1 result-bit-array
)
1363 (bit-vector (eql t
)))
1364 '(bit-not bit-array-1 bit-array-1
))
1366 ;;; Pick off some constant cases.
1367 (defoptimizer (array-header-p derive-type
) ((array))
1368 (let ((type (lvar-type array
)))
1369 (cond ((not (array-type-p type
))
1370 ;; FIXME: use analogue of ARRAY-TYPE-DIMENSIONS-OR-GIVE-UP
1373 (let ((dims (array-type-dimensions type
)))
1374 (cond ((csubtypep type
(specifier-type '(simple-array * (*))))
1376 (specifier-type 'null
))
1377 ((and (listp dims
) (/= (length dims
) 1))
1378 ;; multi-dimensional array, will have a header
1379 (specifier-type '(eql t
)))
1380 ((eql (array-type-complexp type
) t
)
1381 (specifier-type '(eql t
)))