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 (give-up-ir1-transform
165 "~@<lower array bounds unknown or negative and upper bounds not ~
168 (integerp x
))) ; might be NIL or *
170 (let ((dimensions (array-type-dimensions-or-give-up
171 (lvar-conservative-type array
))))
172 ;; Might be *. (Note: currently this is never true, because the type
173 ;; derivation infers the rank from the call to ARRAY-IN-BOUNDS-P, but
174 ;; let's keep this future proof.)
175 (when (eq '* dimensions
)
176 (give-up-ir1-transform "array bounds unknown"))
177 ;; shortcut for zero dimensions
178 (when (some (lambda (dim)
179 (and (bound-known-p dim
) (zerop dim
)))
182 ;; we first collect the subscripts LVARs' bounds and see whether
183 ;; we can already decide on the result of the optimization without
184 ;; even taking a look at the dimensions.
185 (flet ((subscript-bounds (subscript)
186 (let* ((type1 (lvar-type subscript
))
187 (type2 (if (csubtypep type1
(specifier-type 'integer
))
188 (weaken-integer-type type1
:range-only t
)
190 (low (if (integer-type-p type2
)
191 (numeric-type-low type2
)
193 (high (numeric-type-high type2
)))
195 ((and (or (not (bound-known-p low
)) (minusp low
))
196 (or (not (bound-known-p high
)) (not (minusp high
))))
197 ;; can't be sure about the lower bound and the upper bound
198 ;; does not give us a definite clue either.
200 ((and (bound-known-p high
) (minusp high
))
201 (return nil
)) ; definitely below lower bound (zero).
204 (let* ((subscripts-bounds (mapcar #'subscript-bounds subscripts
))
205 (subscripts-lower-bound (mapcar #'car subscripts-bounds
))
206 (subscripts-upper-bound (mapcar #'cdr subscripts-bounds
))
208 (mapcar (lambda (low high dim
)
210 ;; first deal with infinite bounds
211 ((some (complement #'bound-known-p
) (list low high dim
))
212 (when (and (bound-known-p dim
) (bound-known-p low
) (<= dim low
))
214 ;; now we know all bounds
218 (aver (not (minusp low
)))
222 subscripts-lower-bound
223 subscripts-upper-bound
225 (if (eql in-bounds
(length dimensions
))
229 (defoptimizer (aref derive-type
) ((array &rest indices
) node
)
230 (assert-array-rank array
(length indices
))
231 (derive-aref-type array
))
233 (defoptimizer ((setf aref
) derive-type
) ((new-value array
&rest subscripts
))
234 (assert-array-rank array
(length subscripts
))
235 (assert-new-value-type new-value array
))
237 (macrolet ((define (name)
238 `(defoptimizer (,name derive-type
) ((array index
))
239 (derive-aref-type array
))))
240 (define hairy-data-vector-ref
)
241 (define hairy-data-vector-ref
/check-bounds
)
242 (define data-vector-ref
))
245 (defoptimizer (data-vector-ref-with-offset derive-type
) ((array index offset
))
246 (derive-aref-type array
))
248 (macrolet ((define (name)
249 `(defoptimizer (,name derive-type
) ((array index new-value
))
250 (assert-new-value-type new-value array
))))
251 (define hairy-data-vector-set
)
252 (define hairy-data-vector-set
/check-bounds
)
253 (define data-vector-set
))
256 (defoptimizer (data-vector-set-with-offset derive-type
) ((array index offset new-value
))
257 (assert-new-value-type new-value array
))
259 ;;; Figure out the type of the data vector if we know the argument
261 (defun derive-%with-array-data
/mumble-type
(array)
262 (let ((atype (lvar-type array
)))
263 (when (array-type-p atype
)
265 `(simple-array ,(type-specifier
266 (array-type-specialized-element-type atype
))
268 (defoptimizer (%with-array-data derive-type
) ((array start end
))
269 (derive-%with-array-data
/mumble-type array
))
270 (defoptimizer (%with-array-data
/fp derive-type
) ((array start end
))
271 (derive-%with-array-data
/mumble-type array
))
273 (defoptimizer (array-row-major-index derive-type
) ((array &rest indices
))
274 (assert-array-rank array
(length indices
))
277 (defoptimizer (row-major-aref derive-type
) ((array index
))
278 (derive-aref-type array
))
280 (defoptimizer (%set-row-major-aref derive-type
) ((array index new-value
))
281 (assert-new-value-type new-value array
))
283 (defun derive-make-array-type (dims element-type adjustable
284 fill-pointer displaced-to
)
285 (let* ((simple (and (unsupplied-or-nil adjustable
)
286 (unsupplied-or-nil displaced-to
)
287 (unsupplied-or-nil fill-pointer
)))
289 (or `(,(if simple
'simple-array
'array
)
290 ,(cond ((not element-type
) t
)
291 ((ctype-p element-type
)
292 (type-specifier element-type
))
293 ((constant-lvar-p element-type
)
294 (let ((ctype (careful-specifier-type
295 (lvar-value element-type
))))
297 ((or (null ctype
) (contains-unknown-type-p ctype
)) '*)
298 (t (sb!xc
:upgraded-array-element-type
299 (lvar-value element-type
))))))
302 ,(cond ((constant-lvar-p dims
)
303 (let* ((val (lvar-value dims
))
304 (cdims (if (listp val
) val
(list val
))))
308 ((csubtypep (lvar-type dims
)
309 (specifier-type 'integer
))
314 (if (and (not simple
)
315 (or (supplied-and-true adjustable
)
316 (supplied-and-true displaced-to
)
317 (supplied-and-true fill-pointer
)))
318 (careful-specifier-type `(and ,spec
(not simple-array
)))
319 (careful-specifier-type spec
))))
321 (defoptimizer (make-array derive-type
)
322 ((dims &key element-type adjustable fill-pointer displaced-to
))
323 (derive-make-array-type dims element-type adjustable
324 fill-pointer displaced-to
))
326 (defoptimizer (%make-array derive-type
)
327 ((dims widetag n-bits
&key adjustable fill-pointer displaced-to
))
328 (declare (ignore n-bits
))
329 (let ((saetp (and (constant-lvar-p widetag
)
330 (find (lvar-value widetag
)
331 sb
!vm
:*specialized-array-element-type-properties
*
332 :key
#'sb
!vm
:saetp-typecode
))))
333 (derive-make-array-type dims
(if saetp
334 (sb!vm
:saetp-ctype saetp
)
336 adjustable fill-pointer displaced-to
)))
341 ;;; Convert VECTOR into a MAKE-ARRAY.
342 (define-source-transform vector
(&rest elements
)
343 `(make-array ,(length elements
) :initial-contents
(list ,@elements
)))
345 ;;; Just convert it into a MAKE-ARRAY.
346 (deftransform make-string
((length &key
347 (element-type 'character
)
349 #.
*default-init-char-form
*)))
350 `(the simple-string
(make-array (the index length
)
351 :element-type element-type
352 ,@(when initial-element
353 '(:initial-element initial-element
)))))
355 ;; Traverse the :INTIAL-CONTENTS argument to an array constructor call,
356 ;; changing the skeleton of the data to be constructed by calls to LIST
357 ;; and wrapping some declarations around each array cell's constructor.
358 ;; If a macro is involved, expand it before traversing.
360 ;; - Despite the effort to handle multidimensional arrays here,
361 ;; an array-header will not be stack-allocated, so the data won't be either.
362 ;; - inline functions whose behavior is merely to call LIST don't work
363 ;; e.g. :INITIAL-CONTENTS (MY-LIST a b) ; where MY-LIST is inline
364 ;; ; and effectively just (LIST ...)
365 ;; - in the current implementation it is only with difficulty that
366 ;; backquoted vectors could be used as initializers because BACKQ-VECTOR
367 ;; is not the analogous function to VECTOR. (New backq macro fixes that.)
368 (defun rewrite-initial-contents (rank initial-contents env
)
369 (named-let recurse
((rank rank
) (data initial-contents
))
370 (declare (index rank
))
372 (flet ((sequence-constructor-p (form)
373 (member (car form
) '(list vector sb
!impl
::backq-list
))))
375 (cond ((not (listp data
)) data
)
376 ((sequence-constructor-p data
)
377 `(list ,@(mapcar (lambda (dim) (recurse (1- rank
) dim
))
379 ((and (sb!xc
:macro-function
(car data
) env
)
380 (listp (setq expanded
(sb!xc
:macroexpand data env
)))
381 (sequence-constructor-p expanded
))
382 (recurse rank expanded
))
384 ;; This is the important bit: once we are past the level of
385 ;; :INITIAL-CONTENTS that relates to the array structure, reinline LIST
386 ;; and VECTOR so that nested DX isn't screwed up.
387 `(locally (declare (inline list vector
)) ,data
))))
389 ;;; Prevent open coding DIMENSION and :INITIAL-CONTENTS arguments, so that we
390 ;;; can pick them apart in the DEFTRANSFORMS, and transform '(3) style
391 ;;; dimensions to integer args directly.
392 (define-source-transform make-array
(dimensions &rest keyargs
&environment env
)
393 (if (or (and (fun-lexically-notinline-p 'list
)
394 (fun-lexically-notinline-p 'vector
))
395 (oddp (length keyargs
)))
397 (multiple-value-bind (new-dimensions rank
)
398 (flet ((constant-dims (dimensions)
399 (let* ((dims (constant-form-value dimensions env
))
400 (canon (if (listp dims
) dims
(list dims
)))
401 (rank (length canon
)))
402 (values (if (= rank
1)
403 (list 'quote
(car canon
))
406 (cond ((sb!xc
:constantp dimensions env
)
407 (constant-dims dimensions
))
408 ((and (consp dimensions
) (eq 'list dimensions
))
409 (values dimensions
(length (cdr dimensions
))))
411 (values dimensions nil
))))
412 (let ((initial-contents (getf keyargs
:initial-contents
)))
413 (when (and initial-contents rank
)
414 (setf keyargs
(copy-list keyargs
)
415 (getf keyargs
:initial-contents
)
416 (rewrite-initial-contents rank initial-contents env
))))
417 `(locally (declare (notinline list vector
))
418 (make-array ,new-dimensions
,@keyargs
)))))
420 ;;; This baby is a bit of a monster, but it takes care of any MAKE-ARRAY
421 ;;; call which creates a vector with a known element type -- and tries
422 ;;; to do a good job with all the different ways it can happen.
423 (defun transform-make-array-vector (length element-type initial-element
424 initial-contents call
)
425 (aver (or (not element-type
) (constant-lvar-p element-type
)))
426 (let* ((c-length (when (constant-lvar-p length
)
427 (lvar-value length
)))
428 (elt-spec (if element-type
429 (lvar-value element-type
)
431 (elt-ctype (ir1-transform-specifier-type elt-spec
))
432 (saetp (if (unknown-type-p elt-ctype
)
433 (give-up-ir1-transform "~S is an unknown type: ~S"
434 :element-type elt-spec
)
435 (find-saetp-by-ctype elt-ctype
)))
436 (default-initial-element (sb!vm
:saetp-initial-element-default saetp
))
437 (n-bits (sb!vm
:saetp-n-bits saetp
))
438 (typecode (sb!vm
:saetp-typecode saetp
))
439 (n-pad-elements (sb!vm
:saetp-n-pad-elements saetp
))
442 (ceiling (* (+ c-length n-pad-elements
) n-bits
)
444 (let ((padded-length-form (if (zerop n-pad-elements
)
446 `(+ length
,n-pad-elements
))))
449 ((>= n-bits sb
!vm
:n-word-bits
)
450 `(* ,padded-length-form
452 ,(the fixnum
(/ n-bits sb
!vm
:n-word-bits
))))
454 (let ((n-elements-per-word (/ sb
!vm
:n-word-bits n-bits
)))
455 (declare (type index n-elements-per-word
)) ; i.e., not RATIO
456 `(ceiling (truly-the index
,padded-length-form
)
457 ,n-elements-per-word
)))))))
459 `(simple-array ,(sb!vm
:saetp-specifier saetp
) (,(or c-length
'*))))
461 `(truly-the ,result-spec
462 (allocate-vector ,typecode
(the index length
) ,n-words-form
))))
463 (cond ((and initial-element initial-contents
)
464 (abort-ir1-transform "Both ~S and ~S specified."
465 :initial-contents
:initial-element
))
466 ;; :INITIAL-CONTENTS (LIST ...), (VECTOR ...) and `(1 1 ,x) with a
468 ((and initial-contents c-length
469 (lvar-matches initial-contents
470 :fun-names
'(list vector sb
!impl
::backq-list
)
471 :arg-count c-length
))
472 (let ((parameters (eliminate-keyword-args
473 call
1 '((:element-type element-type
)
474 (:initial-contents initial-contents
))))
475 (elt-vars (make-gensym-list c-length
))
476 (lambda-list '(length)))
477 (splice-fun-args initial-contents
:any c-length
)
478 (dolist (p parameters
)
481 (if (eq p
'initial-contents
)
484 `(lambda ,lambda-list
485 (declare (type ,elt-spec
,@elt-vars
)
486 (ignorable ,@lambda-list
))
487 (truly-the ,result-spec
488 (initialize-vector ,alloc-form
,@elt-vars
)))))
489 ;; constant :INITIAL-CONTENTS and LENGTH
490 ((and initial-contents c-length
(constant-lvar-p initial-contents
))
491 (let ((contents (lvar-value initial-contents
)))
492 (unless (= c-length
(length contents
))
493 (abort-ir1-transform "~S has ~S elements, vector length is ~S."
494 :initial-contents
(length contents
) c-length
))
495 (let ((parameters (eliminate-keyword-args
496 call
1 '((:element-type element-type
)
497 (:initial-contents initial-contents
)))))
498 `(lambda (length ,@parameters
)
499 (declare (ignorable ,@parameters
))
500 (truly-the ,result-spec
501 (initialize-vector ,alloc-form
502 ,@(map 'list
(lambda (elt)
503 `(the ,elt-spec
',elt
))
505 ;; any other :INITIAL-CONTENTS
507 (let ((parameters (eliminate-keyword-args
508 call
1 '((:element-type element-type
)
509 (:initial-contents initial-contents
)))))
510 `(lambda (length ,@parameters
)
511 (declare (ignorable ,@parameters
))
512 (unless (= length
(length initial-contents
))
513 (error "~S has ~S elements, vector length is ~S."
514 :initial-contents
(length initial-contents
) length
))
515 (truly-the ,result-spec
516 (replace ,alloc-form initial-contents
)))))
517 ;; :INITIAL-ELEMENT, not EQL to the default
518 ((and initial-element
519 (or (not (constant-lvar-p initial-element
))
520 (not (eql default-initial-element
(lvar-value initial-element
)))))
521 (let ((parameters (eliminate-keyword-args
522 call
1 '((:element-type element-type
)
523 (:initial-element initial-element
))))
524 (init (if (constant-lvar-p initial-element
)
525 (list 'quote
(lvar-value initial-element
))
527 `(lambda (length ,@parameters
)
528 (declare (ignorable ,@parameters
))
529 (truly-the ,result-spec
530 (fill ,alloc-form
(the ,elt-spec
,init
))))))
531 ;; just :ELEMENT-TYPE, or maybe with :INITIAL-ELEMENT EQL to the
535 (unless (ctypep default-initial-element elt-ctype
)
536 ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE
537 ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If
538 ;; INITIAL-ELEMENT is not supplied, the consequences of later
539 ;; reading an uninitialized element of new-array are undefined,"
540 ;; so this could be legal code as long as the user plans to
541 ;; write before he reads, and if he doesn't we're free to do
542 ;; anything we like. But in case the user doesn't know to write
543 ;; elements before he reads elements (or to read manuals before
544 ;; he writes code:-), we'll signal a STYLE-WARNING in case he
545 ;; didn't realize this.
547 (compiler-warn "~S ~S is not a ~S"
548 :initial-element default-initial-element
550 (compiler-style-warn "The default initial element ~S is not a ~S."
551 default-initial-element
553 (let ((parameters (eliminate-keyword-args
554 call
1 '((:element-type element-type
)
555 (:initial-element initial-element
)))))
556 `(lambda (length ,@parameters
)
557 (declare (ignorable ,@parameters
))
560 ;;; IMPORTANT: The order of these three MAKE-ARRAY forms matters: the least
561 ;;; specific must come first, otherwise suboptimal transforms will result for
564 (deftransform make-array
((dims &key initial-element element-type
565 adjustable fill-pointer
)
568 (delay-ir1-transform node
:constraint
)
569 (let* ((eltype (cond ((not element-type
) t
)
570 ((not (constant-lvar-p element-type
))
571 (give-up-ir1-transform
572 "ELEMENT-TYPE is not constant."))
574 (lvar-value element-type
))))
575 (eltype-type (ir1-transform-specifier-type eltype
))
576 (saetp (if (unknown-type-p eltype-type
)
577 (give-up-ir1-transform
578 "ELEMENT-TYPE ~s is not a known type"
581 sb
!vm
:*specialized-array-element-type-properties
*
582 :key
#'sb
!vm
:saetp-ctype
584 (creation-form `(%make-array
587 (sb!vm
:saetp-typecode saetp
)
588 (give-up-ir1-transform))
589 ,(sb!vm
:saetp-n-bits saetp
)
591 '(:fill-pointer fill-pointer
))
593 '(:adjustable adjustable
)))))
594 (cond ((or (not initial-element
)
595 (and (constant-lvar-p initial-element
)
596 (eql (lvar-value initial-element
)
597 (sb!vm
:saetp-initial-element-default saetp
))))
600 ;; error checking for target, disabled on the host because
601 ;; (CTYPE-OF #\Null) is not possible.
603 (when (constant-lvar-p initial-element
)
604 (let ((value (lvar-value initial-element
)))
606 ((not (ctypep value
(sb!vm
:saetp-ctype saetp
)))
607 ;; this case will cause an error at runtime, so we'd
608 ;; better WARN about it now.
609 (warn 'array-initial-element-mismatch
610 :format-control
"~@<~S is not a ~S (which is the ~
615 (type-specifier (sb!vm
:saetp-ctype saetp
))
616 'upgraded-array-element-type
618 ((not (ctypep value eltype-type
))
619 ;; this case will not cause an error at runtime, but
620 ;; it's still worth STYLE-WARNing about.
621 (compiler-style-warn "~S is not a ~S."
623 `(let ((array ,creation-form
))
624 (multiple-value-bind (vector)
625 (%data-vector-and-index array
0)
626 (fill vector
(the ,(sb!vm
:saetp-specifier saetp
) initial-element
)))
629 ;;; The list type restriction does not ensure that the result will be a
630 ;;; multi-dimensional array. But the lack of adjustable, fill-pointer,
631 ;;; and displaced-to keywords ensures that it will be simple.
633 ;;; FIXME: should we generalize this transform to non-simple (though
634 ;;; non-displaced-to) arrays, given that we have %WITH-ARRAY-DATA to
635 ;;; deal with those? Maybe when the DEFTRANSFORM
636 ;;; %DATA-VECTOR-AND-INDEX in the VECTOR case problem is solved? --
638 (deftransform make-array
((dims &key
639 element-type initial-element initial-contents
)
641 (:element-type
(constant-arg *))
643 (:initial-contents
*))
647 (when (lvar-matches dims
:fun-names
'(list) :arg-count
1)
648 (let ((length (car (splice-fun-args dims
:any
1))))
649 (return-from make-array
650 (transform-make-array-vector length
655 (unless (constant-lvar-p dims
)
656 (give-up-ir1-transform
657 "The dimension list is not constant; cannot open code array creation."))
658 (let ((dims (lvar-value dims
))
659 (element-type-ctype (and (constant-lvar-p element-type
)
660 (ir1-transform-specifier-type
661 (lvar-value element-type
)))))
662 (when (contains-unknown-type-p element-type-ctype
)
663 (give-up-ir1-transform))
664 (unless (every #'integerp dims
)
665 (give-up-ir1-transform
666 "The dimension list contains something other than an integer: ~S"
668 (if (= (length dims
) 1)
669 `(make-array ',(car dims
)
671 '(:element-type element-type
))
672 ,@(when initial-element
673 '(:initial-element initial-element
))
674 ,@(when initial-contents
675 '(:initial-contents initial-contents
)))
676 (let* ((total-size (reduce #'* dims
))
679 ,(cond ((null element-type
) t
)
681 (sb!xc
:upgraded-array-element-type
682 (lvar-value element-type
)))
684 ,(make-list rank
:initial-element
'*))))
685 `(let ((header (make-array-header sb
!vm
:simple-array-widetag
,rank
))
686 (data (make-array ,total-size
688 '(:element-type element-type
))
689 ,@(when initial-element
690 '(:initial-element initial-element
)))))
691 ,@(when initial-contents
692 ;; FIXME: This is could be open coded at least a bit too
693 `((sb!impl
::fill-data-vector data
',dims initial-contents
)))
694 (setf (%array-fill-pointer header
) ,total-size
)
695 (setf (%array-fill-pointer-p header
) nil
)
696 (setf (%array-available-elements header
) ,total-size
)
697 (setf (%array-data-vector header
) data
)
698 (setf (%array-displaced-p header
) nil
)
699 (setf (%array-displaced-from header
) nil
)
701 (mapcar (lambda (dim)
702 `(setf (%array-dimension header
,(incf axis
))
705 (truly-the ,spec header
)))))))
707 (deftransform make-array
((dims &key element-type initial-element initial-contents
)
709 (:element-type
(constant-arg *))
711 (:initial-contents
*))
714 (transform-make-array-vector dims
720 ;;;; miscellaneous properties of arrays
722 ;;; Transforms for various array properties. If the property is know
723 ;;; at compile time because of a type spec, use that constant value.
725 ;;; Most of this logic may end up belonging in code/late-type.lisp;
726 ;;; however, here we also need the -OR-GIVE-UP for the transforms, and
727 ;;; maybe this is just too sloppy for actual type logic. -- CSR,
729 (defun array-type-dimensions-or-give-up (type)
730 (labels ((maybe-array-type-dimensions (type)
733 (array-type-dimensions type
))
735 (let* ((types (remove nil
(mapcar #'maybe-array-type-dimensions
736 (union-type-types type
))))
737 (result (car types
)))
738 (dolist (other (cdr types
) result
)
739 (unless (equal result other
)
740 (give-up-ir1-transform
741 "~@<dimensions of arrays in union type ~S do not match~:@>"
742 (type-specifier type
))))))
744 (let* ((types (remove nil
(mapcar #'maybe-array-type-dimensions
745 (intersection-type-types type
))))
746 (result (car types
)))
747 (dolist (other (cdr types
) result
)
748 (unless (equal result other
)
750 "~@<dimensions of arrays in intersection type ~S do not match~:@>"
751 (type-specifier type
)))))))))
752 (or (maybe-array-type-dimensions type
)
753 (give-up-ir1-transform
754 "~@<don't know how to extract array dimensions from type ~S~:@>"
755 (type-specifier type
)))))
757 (defun conservative-array-type-complexp (type)
759 (array-type (array-type-complexp type
))
761 (let ((types (union-type-types type
)))
762 (aver (> (length types
) 1))
763 (let ((result (conservative-array-type-complexp (car types
))))
764 (dolist (type (cdr types
) result
)
765 (unless (eq (conservative-array-type-complexp type
) result
)
766 (return-from conservative-array-type-complexp
:maybe
))))))
767 ;; FIXME: intersection type
770 ;; Let type derivation handle constant cases. We only do easy strength
772 (deftransform array-rank
((array) (array) * :node node
)
773 (let ((array-type (lvar-type array
)))
774 (cond ((eq t
(and (array-type-p array-type
)
775 (array-type-complexp array-type
)))
776 '(%array-rank array
))
778 (delay-ir1-transform node
:constraint
)
779 `(if (array-header-p array
)
783 (defun derive-array-rank (ctype)
784 (let ((array (specifier-type 'array
)))
786 (cond ((not (types-equal-or-intersect x array
))
787 '()) ; Definitely not an array!
789 (let ((dims (array-type-dimensions x
)))
792 (list (length dims
)))))
795 ;; Might as well catch some easy negation cases.
798 (let ((dims (array-type-dimensions x
)))
801 ((every (lambda (dim)
804 (list (length dims
)))
808 (declare (dynamic-extent #'over
#'under
))
809 (multiple-value-bind (not-p ranks
)
810 (list-abstract-type-function ctype
#'over
:under
#'under
)
811 (cond ((eql ranks
'*)
815 (specifier-type `(not (member ,@ranks
))))
817 (specifier-type `(member ,@ranks
))))))))
819 (defoptimizer (array-rank derive-type
) ((array))
820 (derive-array-rank (lvar-type array
)))
822 (defoptimizer (%array-rank derive-type
) ((array))
823 (derive-array-rank (lvar-type array
)))
825 ;;; If we know the dimensions at compile time, just use it. Otherwise,
826 ;;; if we can tell that the axis is in bounds, convert to
827 ;;; %ARRAY-DIMENSION (which just indirects the array header) or length
828 ;;; (if it's simple and a vector).
829 (deftransform array-dimension
((array axis
)
831 (unless (constant-lvar-p axis
)
832 (give-up-ir1-transform "The axis is not constant."))
833 ;; Dimensions may change thanks to ADJUST-ARRAY, so we need the
834 ;; conservative type.
835 (let ((array-type (lvar-conservative-type array
))
836 (axis (lvar-value axis
)))
837 (let ((dims (array-type-dimensions-or-give-up array-type
)))
839 (give-up-ir1-transform
840 "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime."))
841 (unless (> (length dims
) axis
)
842 (abort-ir1-transform "The array has dimensions ~S, ~W is too large."
845 (let ((dim (nth axis dims
)))
846 (cond ((integerp dim
)
849 (ecase (conservative-array-type-complexp array-type
)
851 '(%array-dimension array
0))
853 '(vector-length array
))
855 `(if (array-header-p array
)
856 (%array-dimension array axis
)
857 (vector-length array
)))))
859 '(%array-dimension array axis
)))))))
861 ;;; If the length has been declared and it's simple, just return it.
862 (deftransform length
((vector)
863 ((simple-array * (*))))
864 (let ((type (lvar-type vector
)))
865 (let ((dims (array-type-dimensions-or-give-up type
)))
866 (unless (and (listp dims
) (integerp (car dims
)))
867 (give-up-ir1-transform
868 "Vector length is unknown, must call LENGTH at runtime."))
871 ;;; All vectors can get their length by using VECTOR-LENGTH. If it's
872 ;;; simple, it will extract the length slot from the vector. It it's
873 ;;; complex, it will extract the fill pointer slot from the array
875 (deftransform length
((vector) (vector))
876 '(vector-length vector
))
878 ;;; If a simple array with known dimensions, then VECTOR-LENGTH is a
879 ;;; compile-time constant.
880 (deftransform vector-length
((vector))
881 (let ((vtype (lvar-type vector
)))
882 (let ((dim (first (array-type-dimensions-or-give-up vtype
))))
884 (give-up-ir1-transform))
885 (when (conservative-array-type-complexp vtype
)
886 (give-up-ir1-transform))
889 ;;; Again, if we can tell the results from the type, just use it.
890 ;;; Otherwise, if we know the rank, convert into a computation based
891 ;;; on array-dimension. We can wrap a TRULY-THE INDEX around the
892 ;;; multiplications because we know that the total size must be an
894 (deftransform array-total-size
((array)
896 (let ((array-type (lvar-type array
)))
897 (let ((dims (array-type-dimensions-or-give-up array-type
)))
899 (give-up-ir1-transform "can't tell the rank at compile time"))
901 (do ((form 1 `(truly-the index
902 (* (array-dimension array
,i
) ,form
)))
904 ((= i
(length dims
)) form
))
905 (reduce #'* dims
)))))
907 ;;; Only complex vectors have fill pointers.
908 (deftransform array-has-fill-pointer-p
((array))
909 (let ((array-type (lvar-type array
)))
910 (let ((dims (array-type-dimensions-or-give-up array-type
)))
911 (if (and (listp dims
) (not (= (length dims
) 1)))
913 (ecase (conservative-array-type-complexp array-type
)
919 (give-up-ir1-transform
920 "The array type is ambiguous; must call ~
921 ARRAY-HAS-FILL-POINTER-P at runtime.")))))))
923 ;;; Primitive used to verify indices into arrays. If we can tell at
924 ;;; compile-time or we are generating unsafe code, don't bother with
926 (deftransform %check-bound
((array dimension index
) * * :node node
)
927 (cond ((policy node
(= insert-array-bounds-checks
0))
929 ((not (constant-lvar-p dimension
))
930 (give-up-ir1-transform))
932 (let ((dim (lvar-value dimension
)))
933 ;; FIXME: Can SPEED > SAFETY weaken this check to INTEGER?
934 `(the (integer 0 (,dim
)) index
)))))
938 ;;; This checks to see whether the array is simple and the start and
939 ;;; end are in bounds. If so, it proceeds with those values.
940 ;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that %WITH-ARRAY-DATA
941 ;;; may be further optimized.
943 ;;; Given any ARRAY, bind DATA-VAR to the array's data vector and
944 ;;; START-VAR and END-VAR to the start and end of the designated
945 ;;; portion of the data vector. SVALUE and EVALUE are any start and
946 ;;; end specified to the original operation, and are factored into the
947 ;;; bindings of START-VAR and END-VAR. OFFSET-VAR is the cumulative
948 ;;; offset of all displacements encountered, and does not include
951 ;;; When FORCE-INLINE is set, the underlying %WITH-ARRAY-DATA form is
952 ;;; forced to be inline, overriding the ordinary judgment of the
953 ;;; %WITH-ARRAY-DATA DEFTRANSFORMs. Ordinarily the DEFTRANSFORMs are
954 ;;; fairly picky about their arguments, figuring that if you haven't
955 ;;; bothered to get all your ducks in a row, you probably don't care
956 ;;; that much about speed anyway! But in some cases it makes sense to
957 ;;; do type testing inside %WITH-ARRAY-DATA instead of outside, and
958 ;;; the DEFTRANSFORM can't tell that that's going on, so it can make
959 ;;; sense to use FORCE-INLINE option in that case.
960 (def!macro with-array-data
(((data-var array
&key offset-var
)
961 (start-var &optional
(svalue 0))
962 (end-var &optional
(evalue nil
))
963 &key force-inline check-fill-pointer
)
966 (once-only ((n-array array
)
967 (n-svalue `(the index
,svalue
))
968 (n-evalue `(the (or index null
) ,evalue
)))
969 (let ((check-bounds (policy env
(plusp insert-array-bounds-checks
))))
970 `(multiple-value-bind (,data-var
973 ,@(when offset-var
`(,offset-var
)))
974 (if (not (array-header-p ,n-array
))
975 (let ((,n-array
,n-array
))
976 (declare (type (simple-array * (*)) ,n-array
))
977 ,(once-only ((n-len (if check-fill-pointer
979 `(array-total-size ,n-array
)))
980 (n-end `(or ,n-evalue
,n-len
)))
982 `(if (<= 0 ,n-svalue
,n-end
,n-len
)
983 (values ,n-array
,n-svalue
,n-end
0)
984 ,(if check-fill-pointer
985 `(sequence-bounding-indices-bad-error ,n-array
,n-svalue
,n-evalue
)
986 `(array-bounding-indices-bad-error ,n-array
,n-svalue
,n-evalue
)))
987 `(values ,n-array
,n-svalue
,n-end
0))))
989 `(%with-array-data-macro
,n-array
,n-svalue
,n-evalue
990 :check-bounds
,check-bounds
991 :check-fill-pointer
,check-fill-pointer
)
992 (if check-fill-pointer
993 `(%with-array-data
/fp
,n-array
,n-svalue
,n-evalue
)
994 `(%with-array-data
,n-array
,n-svalue
,n-evalue
))))
997 ;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in
998 ;;; DEFTRANSFORMs and DEFUNs.
999 (def!macro %with-array-data-macro
(array
1006 (with-unique-names (size defaulted-end data cumulative-offset
)
1007 `(let* ((,size
,(if check-fill-pointer
1009 `(array-total-size ,array
)))
1010 (,defaulted-end
(or ,end
,size
)))
1011 ,@(when check-bounds
1012 `((unless (<= ,start
,defaulted-end
,size
)
1013 ,(if check-fill-pointer
1014 `(sequence-bounding-indices-bad-error ,array
,start
,end
)
1015 `(array-bounding-indices-bad-error ,array
,start
,end
)))))
1016 (do ((,data
,array
(%array-data-vector
,data
))
1017 (,cumulative-offset
0
1018 (+ ,cumulative-offset
1019 (%array-displacement
,data
))))
1020 ((not (array-header-p ,data
))
1021 (values (the (simple-array ,element-type
1) ,data
)
1022 (the index
(+ ,cumulative-offset
,start
))
1023 (the index
(+ ,cumulative-offset
,defaulted-end
))
1024 (the index
,cumulative-offset
)))
1025 (declare (type index
,cumulative-offset
))))))
1027 (defun transform-%with-array-data
/muble
(array node check-fill-pointer
)
1028 (let ((element-type (upgraded-element-type-specifier-or-give-up array
))
1029 (type (lvar-type array
))
1030 (check-bounds (policy node
(plusp insert-array-bounds-checks
))))
1031 (if (and (array-type-p type
)
1032 (not (array-type-complexp type
))
1033 (listp (array-type-dimensions type
))
1034 (not (null (cdr (array-type-dimensions type
)))))
1035 ;; If it's a simple multidimensional array, then just return
1036 ;; its data vector directly rather than going through
1037 ;; %WITH-ARRAY-DATA-MACRO. SBCL doesn't generally generate
1038 ;; code that would use this currently, but we have encouraged
1039 ;; users to use WITH-ARRAY-DATA and we may use it ourselves at
1040 ;; some point in the future for optimized libraries or
1043 `(let* ((data (truly-the (simple-array ,element-type
(*))
1044 (%array-data-vector array
)))
1046 (real-end (or end len
)))
1047 (unless (<= 0 start data-end lend
)
1048 (sequence-bounding-indices-bad-error array start end
))
1049 (values data
0 real-end
0))
1050 `(let ((data (truly-the (simple-array ,element-type
(*))
1051 (%array-data-vector array
))))
1052 (values data
0 (or end
(length data
)) 0)))
1053 `(%with-array-data-macro array start end
1054 :check-fill-pointer
,check-fill-pointer
1055 :check-bounds
,check-bounds
1056 :element-type
,element-type
))))
1058 ;; It might very well be reasonable to allow general ARRAY here, I
1059 ;; just haven't tried to understand the performance issues involved.
1060 ;; -- WHN, and also CSR 2002-05-26
1061 (deftransform %with-array-data
((array start end
)
1062 ((or vector simple-array
) index
(or index null
) t
)
1065 :policy
(> speed space
))
1066 "inline non-SIMPLE-vector-handling logic"
1067 (transform-%with-array-data
/muble array node nil
))
1068 (deftransform %with-array-data
/fp
((array start end
)
1069 ((or vector simple-array
) index
(or index null
) t
)
1072 :policy
(> speed space
))
1073 "inline non-SIMPLE-vector-handling logic"
1074 (transform-%with-array-data
/muble array node t
))
1076 ;;;; array accessors
1078 ;;; We convert all typed array accessors into AREF and (SETF AREF) with type
1079 ;;; assertions on the array.
1080 (macrolet ((define-bit-frob (reffer simplep
)
1082 (define-source-transform ,reffer
(a &rest i
)
1083 `(aref (the (,',(if simplep
'simple-array
'array
)
1085 ,(mapcar (constantly '*) i
))
1087 (define-source-transform (setf ,reffer
) (value a
&rest i
)
1088 `(setf (aref (the (,',(if simplep
'simple-array
'array
)
1090 ,(mapcar (constantly '*) i
))
1093 (define-bit-frob sbit t
)
1094 (define-bit-frob bit nil
))
1096 (macrolet ((define-frob (reffer setter type
)
1098 (define-source-transform ,reffer
(a i
)
1099 `(aref (the ,',type
,a
) ,i
))
1100 (define-source-transform ,setter
(a i v
)
1101 `(setf (aref (the ,',type
,a
) ,i
) ,v
)))))
1102 (define-frob schar %scharset simple-string
)
1103 (define-frob char %charset string
))
1105 ;;; We transform SVREF and %SVSET directly into DATA-VECTOR-REF/SET: this is
1106 ;;; around 100 times faster than going through the general-purpose AREF
1107 ;;; transform which ends up doing a lot of work -- and introducing many
1108 ;;; intermediate lambdas, each meaning a new trip through the compiler -- to
1109 ;;; get the same result.
1111 ;;; FIXME: [S]CHAR, and [S]BIT above would almost certainly benefit from a similar
1113 (define-source-transform svref
(vector index
)
1114 (let ((elt-type (or (when (symbolp vector
)
1115 (let ((var (lexenv-find vector vars
)))
1116 (when (lambda-var-p var
)
1118 (array-type-declared-element-type (lambda-var-type var
))))))
1120 (with-unique-names (n-vector)
1121 `(let ((,n-vector
,vector
))
1122 (the ,elt-type
(data-vector-ref
1123 (the simple-vector
,n-vector
)
1124 (%check-bound
,n-vector
(length ,n-vector
) ,index
)))))))
1126 (define-source-transform %svset
(vector index value
)
1127 (let ((elt-type (or (when (symbolp vector
)
1128 (let ((var (lexenv-find vector vars
)))
1129 (when (lambda-var-p var
)
1131 (array-type-declared-element-type (lambda-var-type var
))))))
1133 (with-unique-names (n-vector)
1134 `(let ((,n-vector
,vector
))
1135 (truly-the ,elt-type
(data-vector-set
1136 (the simple-vector
,n-vector
)
1137 (%check-bound
,n-vector
(length ,n-vector
) ,index
)
1138 (the ,elt-type
,value
)))))))
1140 (macrolet (;; This is a handy macro for computing the row-major index
1141 ;; given a set of indices. We wrap each index with a call
1142 ;; to %CHECK-BOUND to ensure that everything works out
1143 ;; correctly. We can wrap all the interior arithmetic with
1144 ;; TRULY-THE INDEX because we know the resultant
1145 ;; row-major index must be an index.
1146 (with-row-major-index ((array indices index
&optional new-value
)
1148 `(let (n-indices dims
)
1149 (dotimes (i (length ,indices
))
1150 (push (make-symbol (format nil
"INDEX-~D" i
)) n-indices
)
1151 (push (make-symbol (format nil
"DIM-~D" i
)) dims
))
1152 (setf n-indices
(nreverse n-indices
))
1153 (setf dims
(nreverse dims
))
1154 `(lambda (,@',(when new-value
(list new-value
))
1155 ,',array
,@n-indices
)
1156 (declare (ignorable ,',array
))
1157 (let* (,@(let ((,index -
1))
1158 (mapcar (lambda (name)
1159 `(,name
(array-dimension
1166 (do* ((dims dims
(cdr dims
))
1167 (indices n-indices
(cdr indices
))
1168 (last-dim nil
(car dims
))
1169 (form `(%check-bound
,',array
1181 ((null (cdr dims
)) form
)))))
1184 ;; Just return the index after computing it.
1185 (deftransform array-row-major-index
((array &rest indices
))
1186 (with-row-major-index (array indices index
)
1189 ;; Convert AREF and (SETF AREF) into a HAIRY-DATA-VECTOR-REF (or
1190 ;; HAIRY-DATA-VECTOR-SET) with the set of indices replaced with the an
1191 ;; expression for the row major index.
1192 (deftransform aref
((array &rest indices
))
1193 (with-row-major-index (array indices index
)
1194 (hairy-data-vector-ref array index
)))
1196 (deftransform (setf aref
) ((new-value array
&rest subscripts
))
1197 (with-row-major-index (array subscripts index new-value
)
1198 (hairy-data-vector-set array index new-value
))))
1200 ;; For AREF of vectors we do the bounds checking in the callee. This
1201 ;; lets us do a significantly more efficient check for simple-arrays
1202 ;; without bloating the code. If we already know the type of the array
1203 ;; with sufficient precision, skip directly to DATA-VECTOR-REF.
1204 (deftransform aref
((array index
) (t t
) * :node node
)
1205 (let* ((type (lvar-type array
))
1206 (element-ctype (array-type-upgraded-element-type type
)))
1208 ((eql element-ctype
*empty-type
*)
1209 `(data-nil-vector-ref array index
))
1210 ((and (array-type-p type
)
1211 (null (array-type-complexp type
))
1212 (not (eql element-ctype
*wild-type
*))
1213 (eql (length (array-type-dimensions type
)) 1))
1214 (let* ((declared-element-ctype (array-type-declared-element-type type
))
1216 `(data-vector-ref array
1217 (%check-bound array
(array-dimension array
0) index
))))
1218 (if (type= declared-element-ctype element-ctype
)
1220 `(the ,(type-specifier declared-element-ctype
) ,bare-form
))))
1221 ((policy node
(zerop insert-array-bounds-checks
))
1222 `(hairy-data-vector-ref array index
))
1223 (t `(hairy-data-vector-ref/check-bounds array index
)))))
1225 (deftransform (setf aref
) ((new-value array index
) (t t t
) * :node node
)
1226 (if (policy node
(zerop insert-array-bounds-checks
))
1227 `(hairy-data-vector-set array index new-value
)
1228 `(hairy-data-vector-set/check-bounds array index new-value
)))
1230 ;;; But if we find out later that there's some useful type information
1231 ;;; available, switch back to the normal one to give other transforms
1233 (macrolet ((define (name transform-to extra extra-type
)
1234 (declare (ignore extra-type
))
1235 `(deftransform ,name
((array index
,@extra
))
1236 (let* ((type (lvar-type array
))
1237 (element-type (array-type-upgraded-element-type type
))
1238 (declared-type (type-specifier
1239 (array-type-declared-element-type type
))))
1240 ;; If an element type has been declared, we want to
1241 ;; use that information it for type checking (even
1242 ;; if the access can't be optimized due to the array
1243 ;; not being simple).
1244 (when (and (eql element-type
*wild-type
*)
1245 ;; This type logic corresponds to the special
1246 ;; case for strings in HAIRY-DATA-VECTOR-REF
1247 ;; (generic/vm-tran.lisp)
1248 (not (csubtypep type
(specifier-type 'simple-string
))))
1249 (when (or (not (array-type-p type
))
1250 ;; If it's a simple array, we might be able
1251 ;; to inline the access completely.
1252 (not (null (array-type-complexp type
))))
1253 (give-up-ir1-transform
1254 "Upgraded element type of array is not known at compile time.")))
1256 ``(truly-the ,declared-type
1257 (,',transform-to array
1259 (array-dimension array
0)
1261 (the ,declared-type
,@',extra
)))
1262 ``(the ,declared-type
1263 (,',transform-to array
1265 (array-dimension array
0)
1267 (define hairy-data-vector-ref
/check-bounds
1268 hairy-data-vector-ref nil nil
)
1269 (define hairy-data-vector-set
/check-bounds
1270 hairy-data-vector-set
(new-value) (*)))
1272 ;;; Just convert into a HAIRY-DATA-VECTOR-REF (or
1273 ;;; HAIRY-DATA-VECTOR-SET) after checking that the index is inside the
1274 ;;; array total size.
1275 (deftransform row-major-aref
((array index
))
1276 `(hairy-data-vector-ref array
1277 (%check-bound array
(array-total-size array
) index
)))
1278 (deftransform %set-row-major-aref
((array index new-value
))
1279 `(hairy-data-vector-set array
1280 (%check-bound array
(array-total-size array
) index
)
1283 ;;;; bit-vector array operation canonicalization
1285 ;;;; We convert all bit-vector operations to have the result array
1286 ;;;; specified. This allows any result allocation to be open-coded,
1287 ;;;; and eliminates the need for any VM-dependent transforms to handle
1290 (macrolet ((def (fun)
1292 (deftransform ,fun
((bit-array-1 bit-array-2
1293 &optional result-bit-array
)
1294 (bit-vector bit-vector
&optional null
) *
1295 :policy
(>= speed space
))
1296 `(,',fun bit-array-1 bit-array-2
1297 (make-array (array-dimension bit-array-1
0) :element-type
'bit
)))
1298 ;; If result is T, make it the first arg.
1299 (deftransform ,fun
((bit-array-1 bit-array-2 result-bit-array
)
1300 (bit-vector bit-vector
(eql t
)) *)
1301 `(,',fun bit-array-1 bit-array-2 bit-array-1
)))))
1313 ;;; Similar for BIT-NOT, but there is only one arg...
1314 (deftransform bit-not
((bit-array-1 &optional result-bit-array
)
1315 (bit-vector &optional null
) *
1316 :policy
(>= speed space
))
1317 '(bit-not bit-array-1
1318 (make-array (array-dimension bit-array-1
0) :element-type
'bit
)))
1319 (deftransform bit-not
((bit-array-1 result-bit-array
)
1320 (bit-vector (eql t
)))
1321 '(bit-not bit-array-1 bit-array-1
))
1323 ;;; Pick off some constant cases.
1324 (defoptimizer (array-header-p derive-type
) ((array))
1325 (let ((type (lvar-type array
)))
1326 (cond ((not (array-type-p type
))
1327 ;; FIXME: use analogue of ARRAY-TYPE-DIMENSIONS-OR-GIVE-UP
1330 (let ((dims (array-type-dimensions type
)))
1331 (cond ((csubtypep type
(specifier-type '(simple-array * (*))))
1333 (specifier-type 'null
))
1334 ((and (listp dims
) (/= (length dims
) 1))
1335 ;; multi-dimensional array, will have a header
1336 (specifier-type '(eql t
)))
1337 ((eql (array-type-complexp type
) t
)
1338 (specifier-type '(eql t
)))