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
))
76 (element-type *empty-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
*empty-type
*)
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 ;; KLUDGE: there is no good answer here, but at least
103 ;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be
104 ;; erroneously optimized (see generic/vm-tran.lisp) -- CSR,
106 (values *wild-type
* nil
))))
108 (defun array-type-declared-element-type (type)
109 (if (array-type-p type
)
110 (array-type-element-type type
)
113 ;;; The ``new-value'' for array setters must fit in the array, and the
114 ;;; return type is going to be the same as the new-value for SETF
116 (defun assert-new-value-type (new-value array
)
117 (let ((type (lvar-type array
)))
118 (when (array-type-p type
)
121 (array-type-specialized-element-type type
)
122 (lexenv-policy (node-lexenv (lvar-dest new-value
))))))
123 (lvar-type new-value
))
125 (defun assert-array-complex (array)
128 (make-array-type :complexp t
129 :element-type
*wild-type
*)
130 (lexenv-policy (node-lexenv (lvar-dest array
))))
133 ;;; Return true if ARG is NIL, or is a constant-lvar whose
134 ;;; value is NIL, false otherwise.
135 (defun unsupplied-or-nil (arg)
136 (declare (type (or lvar null
) arg
))
138 (and (constant-lvar-p arg
)
139 (not (lvar-value arg
)))))
141 ;;;; DERIVE-TYPE optimizers
143 ;;; Array operations that use a specific number of indices implicitly
144 ;;; assert that the array is of that rank.
145 (defun assert-array-rank (array rank
)
148 (specifier-type `(array * ,(make-list rank
:initial-element
'*)))
149 (lexenv-policy (node-lexenv (lvar-dest array
)))))
151 (defun derive-aref-type (array)
152 (multiple-value-bind (uaet other
)
153 (array-type-upgraded-element-type (lvar-type array
))
156 (defoptimizer (array-in-bounds-p derive-type
) ((array &rest indices
))
157 (assert-array-rank array
(length indices
))
160 (deftransform array-in-bounds-p
((array &rest subscripts
))
162 (give-up-ir1-transform
163 "~@<lower array bounds unknown or negative and upper bounds not ~
166 (integerp x
))) ; might be NIL or *
168 (let ((dimensions (array-type-dimensions-or-give-up
169 (lvar-conservative-type array
))))
170 ;; shortcut for zero dimensions
171 (when (some (lambda (dim)
172 (and (bound-known-p dim
) (zerop dim
)))
175 ;; we first collect the subscripts LVARs' bounds and see whether
176 ;; we can already decide on the result of the optimization without
177 ;; even taking a look at the dimensions.
178 (flet ((subscript-bounds (subscript)
179 (let* ((type (lvar-type subscript
))
180 (low (numeric-type-low type
))
181 (high (numeric-type-high type
)))
183 ((and (or (not (bound-known-p low
)) (minusp low
))
184 (or (not (bound-known-p high
)) (not (minusp high
))))
185 ;; can't be sure about the lower bound and the upper bound
186 ;; does not give us a definite clue either.
188 ((and (bound-known-p high
) (minusp high
))
189 (return nil
)) ; definitely below lower bound (zero).
192 (let* ((subscripts-bounds (mapcar #'subscript-bounds subscripts
))
193 (subscripts-lower-bound (mapcar #'car subscripts-bounds
))
194 (subscripts-upper-bound (mapcar #'cdr subscripts-bounds
))
196 (mapcar (lambda (low high dim
)
198 ;; first deal with infinite bounds
199 ((some (complement #'bound-known-p
) (list low high dim
))
200 (when (and (bound-known-p dim
) (bound-known-p low
) (<= dim low
))
202 ;; now we know all bounds
206 (aver (not (minusp low
)))
210 subscripts-lower-bound
211 subscripts-upper-bound
213 (if (eql in-bounds
(length dimensions
))
217 (defoptimizer (aref derive-type
) ((array &rest indices
) node
)
218 (assert-array-rank array
(length indices
))
219 (derive-aref-type array
))
221 (defoptimizer (%aset derive-type
) ((array &rest stuff
))
222 (assert-array-rank array
(1- (length stuff
)))
223 (assert-new-value-type (car (last stuff
)) array
))
225 (macrolet ((define (name)
226 `(defoptimizer (,name derive-type
) ((array index
))
227 (derive-aref-type array
))))
228 (define hairy-data-vector-ref
)
229 (define hairy-data-vector-ref
/check-bounds
)
230 (define data-vector-ref
))
233 (defoptimizer (data-vector-ref-with-offset derive-type
) ((array index offset
))
234 (derive-aref-type array
))
236 (macrolet ((define (name)
237 `(defoptimizer (,name derive-type
) ((array index new-value
))
238 (assert-new-value-type new-value array
))))
239 (define hairy-data-vector-set
)
240 (define hairy-data-vector-set
/check-bounds
)
241 (define data-vector-set
))
244 (defoptimizer (data-vector-set-with-offset derive-type
) ((array index offset new-value
))
245 (assert-new-value-type new-value array
))
247 ;;; Figure out the type of the data vector if we know the argument
249 (defun derive-%with-array-data
/mumble-type
(array)
250 (let ((atype (lvar-type array
)))
251 (when (array-type-p atype
)
253 `(simple-array ,(type-specifier
254 (array-type-specialized-element-type atype
))
256 (defoptimizer (%with-array-data derive-type
) ((array start end
))
257 (derive-%with-array-data
/mumble-type array
))
258 (defoptimizer (%with-array-data
/fp derive-type
) ((array start end
))
259 (derive-%with-array-data
/mumble-type array
))
261 (defoptimizer (array-row-major-index derive-type
) ((array &rest indices
))
262 (assert-array-rank array
(length indices
))
265 (defoptimizer (row-major-aref derive-type
) ((array index
))
266 (derive-aref-type array
))
268 (defoptimizer (%set-row-major-aref derive-type
) ((array index new-value
))
269 (assert-new-value-type new-value array
))
271 (defoptimizer (make-array derive-type
)
272 ((dims &key initial-element element-type initial-contents
273 adjustable fill-pointer displaced-index-offset displaced-to
))
274 (let ((simple (and (unsupplied-or-nil adjustable
)
275 (unsupplied-or-nil displaced-to
)
276 (unsupplied-or-nil fill-pointer
))))
277 (or (careful-specifier-type
278 `(,(if simple
'simple-array
'array
)
279 ,(cond ((not element-type
) t
)
280 ((constant-lvar-p element-type
)
281 (let ((ctype (careful-specifier-type
282 (lvar-value element-type
))))
284 ((or (null ctype
) (unknown-type-p ctype
)) '*)
285 (t (sb!xc
:upgraded-array-element-type
286 (lvar-value element-type
))))))
289 ,(cond ((constant-lvar-p dims
)
290 (let* ((val (lvar-value dims
))
291 (cdims (if (listp val
) val
(list val
))))
295 ((csubtypep (lvar-type dims
)
296 (specifier-type 'integer
))
300 (specifier-type 'array
))))
302 ;;; Complex array operations should assert that their array argument
303 ;;; is complex. In SBCL, vectors with fill-pointers are complex.
304 (defoptimizer (fill-pointer derive-type
) ((vector))
305 (assert-array-complex vector
))
306 (defoptimizer (%set-fill-pointer derive-type
) ((vector index
))
307 (declare (ignorable index
))
308 (assert-array-complex vector
))
310 (defoptimizer (vector-push derive-type
) ((object vector
))
311 (declare (ignorable object
))
312 (assert-array-complex vector
))
313 (defoptimizer (vector-push-extend derive-type
)
314 ((object vector
&optional index
))
315 (declare (ignorable object index
))
316 (assert-array-complex vector
))
317 (defoptimizer (vector-pop derive-type
) ((vector))
318 (assert-array-complex vector
))
322 ;;; Convert VECTOR into a MAKE-ARRAY.
323 (define-source-transform vector
(&rest elements
)
324 `(make-array ,(length elements
) :initial-contents
(list ,@elements
)))
326 ;;; Just convert it into a MAKE-ARRAY.
327 (deftransform make-string
((length &key
328 (element-type 'character
)
330 #.
*default-init-char-form
*)))
331 `(the simple-string
(make-array (the index length
)
332 :element-type element-type
333 ,@(when initial-element
334 '(:initial-element initial-element
)))))
336 ;;; Prevent open coding DIMENSION and :INITIAL-CONTENTS arguments,
337 ;;; so that we can pick them apart.
338 (define-source-transform make-array
(&whole form dimensions
&rest keyargs
340 (if (and (fun-lexically-notinline-p 'list
)
341 (fun-lexically-notinline-p 'vector
))
343 `(locally (declare (notinline list vector
))
344 ;; Transform '(3) style dimensions to integer args directly.
345 ,(if (sb!xc
:constantp dimensions env
)
346 (let ((dims (constant-form-value dimensions env
)))
347 (if (and (listp dims
) (= 1 (length dims
)))
348 `(make-array ',(car dims
) ,@keyargs
)
352 ;;; This baby is a bit of a monster, but it takes care of any MAKE-ARRAY
353 ;;; call which creates a vector with a known element type -- and tries
354 ;;; to do a good job with all the different ways it can happen.
355 (defun transform-make-array-vector (length element-type initial-element
356 initial-contents call
)
357 (aver (or (not element-type
) (constant-lvar-p element-type
)))
358 (let* ((c-length (when (constant-lvar-p length
)
359 (lvar-value length
)))
360 (elt-spec (if element-type
361 (lvar-value element-type
)
363 (elt-ctype (ir1-transform-specifier-type elt-spec
))
364 (saetp (if (unknown-type-p elt-ctype
)
365 (give-up-ir1-transform "~S is an unknown type: ~S"
366 :element-type elt-spec
)
367 (find-saetp-by-ctype elt-ctype
)))
368 (default-initial-element (sb!vm
:saetp-initial-element-default saetp
))
369 (n-bits (sb!vm
:saetp-n-bits saetp
))
370 (typecode (sb!vm
:saetp-typecode saetp
))
371 (n-pad-elements (sb!vm
:saetp-n-pad-elements saetp
))
374 (ceiling (* (+ c-length n-pad-elements
) n-bits
)
376 (let ((padded-length-form (if (zerop n-pad-elements
)
378 `(+ length
,n-pad-elements
))))
381 ((>= n-bits sb
!vm
:n-word-bits
)
382 `(* ,padded-length-form
384 ,(the fixnum
(/ n-bits sb
!vm
:n-word-bits
))))
386 (let ((n-elements-per-word (/ sb
!vm
:n-word-bits n-bits
)))
387 (declare (type index n-elements-per-word
)) ; i.e., not RATIO
388 `(ceiling ,padded-length-form
,n-elements-per-word
)))))))
390 `(simple-array ,(sb!vm
:saetp-specifier saetp
) (,(or c-length
'*))))
392 `(truly-the ,result-spec
393 (allocate-vector ,typecode
(the index length
) ,n-words-form
))))
394 (cond ((and initial-element initial-contents
)
395 (abort-ir1-transform "Both ~S and ~S specified."
396 :initial-contents
:initial-element
))
397 ;; :INITIAL-CONTENTS (LIST ...), (VECTOR ...) and `(1 1 ,x) with a
399 ((and initial-contents c-length
400 (lvar-matches initial-contents
401 :fun-names
'(list vector sb
!impl
::backq-list
)
402 :arg-count c-length
))
403 (let ((parameters (eliminate-keyword-args
404 call
1 '((:element-type element-type
)
405 (:initial-contents initial-contents
))))
406 (elt-vars (make-gensym-list c-length
))
407 (lambda-list '(length)))
408 (splice-fun-args initial-contents
:any c-length
)
409 (dolist (p parameters
)
412 (if (eq p
'initial-contents
)
415 `(lambda ,lambda-list
416 (declare (type ,elt-spec
,@elt-vars
)
417 (ignorable ,@lambda-list
))
418 (truly-the ,result-spec
419 (initialize-vector ,alloc-form
,@elt-vars
)))))
420 ;; constant :INITIAL-CONTENTS and LENGTH
421 ((and initial-contents c-length
(constant-lvar-p initial-contents
))
422 (let ((contents (lvar-value initial-contents
)))
423 (unless (= c-length
(length contents
))
424 (abort-ir1-transform "~S has ~S elements, vector length is ~S."
425 :initial-contents
(length contents
) c-length
))
426 (let ((parameters (eliminate-keyword-args
427 call
1 '((:element-type element-type
)
428 (:initial-contents initial-contents
)))))
429 `(lambda (length ,@parameters
)
430 (declare (ignorable ,@parameters
))
431 (truly-the ,result-spec
432 (initialize-vector ,alloc-form
433 ,@(map 'list
(lambda (elt)
434 `(the ,elt-spec
',elt
))
436 ;; any other :INITIAL-CONTENTS
438 (let ((parameters (eliminate-keyword-args
439 call
1 '((:element-type element-type
)
440 (:initial-contents initial-contents
)))))
441 `(lambda (length ,@parameters
)
442 (declare (ignorable ,@parameters
))
443 (unless (= length
(length initial-contents
))
444 (error "~S has ~S elements, vector length is ~S."
445 :initial-contents
(length initial-contents
) length
))
446 (truly-the ,result-spec
447 (replace ,alloc-form initial-contents
)))))
448 ;; :INITIAL-ELEMENT, not EQL to the default
449 ((and initial-element
450 (or (not (constant-lvar-p initial-element
))
451 (not (eql default-initial-element
(lvar-value initial-element
)))))
452 (let ((parameters (eliminate-keyword-args
453 call
1 '((:element-type element-type
)
454 (:initial-element initial-element
))))
455 (init (if (constant-lvar-p initial-element
)
456 (list 'quote
(lvar-value initial-element
))
458 `(lambda (length ,@parameters
)
459 (declare (ignorable ,@parameters
))
460 (truly-the ,result-spec
461 (fill ,alloc-form
(the ,elt-spec
,init
))))))
462 ;; just :ELEMENT-TYPE, or maybe with :INITIAL-ELEMENT EQL to the
466 (unless (ctypep default-initial-element elt-ctype
)
467 ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE
468 ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If
469 ;; INITIAL-ELEMENT is not supplied, the consequences of later
470 ;; reading an uninitialized element of new-array are undefined,"
471 ;; so this could be legal code as long as the user plans to
472 ;; write before he reads, and if he doesn't we're free to do
473 ;; anything we like. But in case the user doesn't know to write
474 ;; elements before he reads elements (or to read manuals before
475 ;; he writes code:-), we'll signal a STYLE-WARNING in case he
476 ;; didn't realize this.
478 (compiler-warn "~S ~S is not a ~S"
479 :initial-element default-initial-element
481 (compiler-style-warn "The default initial element ~S is not a ~S."
482 default-initial-element
484 (let ((parameters (eliminate-keyword-args
485 call
1 '((:element-type element-type
)
486 (:initial-element initial-element
)))))
487 `(lambda (length ,@parameters
)
488 (declare (ignorable ,@parameters
))
491 ;;; IMPORTANT: The order of these three MAKE-ARRAY forms matters: the least
492 ;;; specific must come first, otherwise suboptimal transforms will result for
495 (deftransform make-array
((dims &key initial-element element-type
496 adjustable fill-pointer
)
498 (when (null initial-element
)
499 (give-up-ir1-transform))
500 (let* ((eltype (cond ((not element-type
) t
)
501 ((not (constant-lvar-p element-type
))
502 (give-up-ir1-transform
503 "ELEMENT-TYPE is not constant."))
505 (lvar-value element-type
))))
506 (eltype-type (ir1-transform-specifier-type eltype
))
507 (saetp (find-if (lambda (saetp)
508 (csubtypep eltype-type
(sb!vm
:saetp-ctype saetp
)))
509 sb
!vm
:*specialized-array-element-type-properties
*))
510 (creation-form `(make-array dims
511 :element-type
',(type-specifier (sb!vm
:saetp-ctype saetp
))
513 '(:fill-pointer fill-pointer
))
515 '(:adjustable adjustable
)))))
518 (give-up-ir1-transform "ELEMENT-TYPE not found in *SAETP*: ~S" eltype
))
520 (cond ((and (constant-lvar-p initial-element
)
521 (eql (lvar-value initial-element
)
522 (sb!vm
:saetp-initial-element-default saetp
)))
525 ;; error checking for target, disabled on the host because
526 ;; (CTYPE-OF #\Null) is not possible.
528 (when (constant-lvar-p initial-element
)
529 (let ((value (lvar-value initial-element
)))
531 ((not (ctypep value
(sb!vm
:saetp-ctype saetp
)))
532 ;; this case will cause an error at runtime, so we'd
533 ;; better WARN about it now.
534 (warn 'array-initial-element-mismatch
535 :format-control
"~@<~S is not a ~S (which is the ~
540 (type-specifier (sb!vm
:saetp-ctype saetp
))
541 'upgraded-array-element-type
543 ((not (ctypep value eltype-type
))
544 ;; this case will not cause an error at runtime, but
545 ;; it's still worth STYLE-WARNing about.
546 (compiler-style-warn "~S is not a ~S."
548 `(let ((array ,creation-form
))
549 (multiple-value-bind (vector)
550 (%data-vector-and-index array
0)
551 (fill vector
(the ,(sb!vm
:saetp-specifier saetp
) initial-element
)))
554 ;;; The list type restriction does not ensure that the result will be a
555 ;;; multi-dimensional array. But the lack of adjustable, fill-pointer,
556 ;;; and displaced-to keywords ensures that it will be simple.
558 ;;; FIXME: should we generalize this transform to non-simple (though
559 ;;; non-displaced-to) arrays, given that we have %WITH-ARRAY-DATA to
560 ;;; deal with those? Maybe when the DEFTRANSFORM
561 ;;; %DATA-VECTOR-AND-INDEX in the VECTOR case problem is solved? --
563 (deftransform make-array
((dims &key
564 element-type initial-element initial-contents
)
566 (:element-type
(constant-arg *))
568 (:initial-contents
*))
572 (when (lvar-matches dims
:fun-names
'(list) :arg-count
1)
573 (let ((length (car (splice-fun-args dims
:any
1))))
574 (return-from make-array
575 (transform-make-array-vector length
580 (unless (constant-lvar-p dims
)
581 (give-up-ir1-transform
582 "The dimension list is not constant; cannot open code array creation."))
583 (let ((dims (lvar-value dims
)))
584 (unless (every #'integerp dims
)
585 (give-up-ir1-transform
586 "The dimension list contains something other than an integer: ~S"
588 (if (= (length dims
) 1)
589 `(make-array ',(car dims
)
591 '(:element-type element-type
))
592 ,@(when initial-element
593 '(:initial-element initial-element
))
594 ,@(when initial-contents
595 '(:initial-contents initial-contents
)))
596 (let* ((total-size (reduce #'* dims
))
599 ,(cond ((null element-type
) t
)
600 ((and (constant-lvar-p element-type
)
601 (ir1-transform-specifier-type
602 (lvar-value element-type
)))
603 (sb!xc
:upgraded-array-element-type
604 (lvar-value element-type
)))
606 ,(make-list rank
:initial-element
'*))))
607 `(let ((header (make-array-header sb
!vm
:simple-array-widetag
,rank
))
608 (data (make-array ,total-size
610 '(:element-type element-type
))
611 ,@(when initial-element
612 '(:initial-element initial-element
)))))
613 ,@(when initial-contents
614 ;; FIXME: This is could be open coded at least a bit too
615 `((sb!impl
::fill-data-vector data
',dims initial-contents
)))
616 (setf (%array-fill-pointer header
) ,total-size
)
617 (setf (%array-fill-pointer-p header
) nil
)
618 (setf (%array-available-elements header
) ,total-size
)
619 (setf (%array-data-vector header
) data
)
620 (setf (%array-displaced-p header
) nil
)
621 (setf (%array-displaced-from header
) nil
)
623 (mapcar (lambda (dim)
624 `(setf (%array-dimension header
,(incf axis
))
627 (truly-the ,spec header
)))))))
629 (deftransform make-array
((dims &key element-type initial-element initial-contents
)
631 (:element-type
(constant-arg *))
633 (:initial-contents
*))
636 (transform-make-array-vector dims
642 ;;;; miscellaneous properties of arrays
644 ;;; Transforms for various array properties. If the property is know
645 ;;; at compile time because of a type spec, use that constant value.
647 ;;; Most of this logic may end up belonging in code/late-type.lisp;
648 ;;; however, here we also need the -OR-GIVE-UP for the transforms, and
649 ;;; maybe this is just too sloppy for actual type logic. -- CSR,
651 (defun array-type-dimensions-or-give-up (type)
652 (labels ((maybe-array-type-dimensions (type)
655 (array-type-dimensions type
))
657 (let* ((types (remove nil
(mapcar #'maybe-array-type-dimensions
658 (union-type-types type
))))
659 (result (car types
)))
660 (dolist (other (cdr types
) result
)
661 (unless (equal result other
)
662 (give-up-ir1-transform
663 "~@<dimensions of arrays in union type ~S do not match~:@>"
664 (type-specifier type
))))))
666 (let* ((types (remove nil
(mapcar #'maybe-array-type-dimensions
667 (intersection-type-types type
))))
668 (result (car types
)))
669 (dolist (other (cdr types
) result
)
670 (unless (equal result other
)
672 "~@<dimensions of arrays in intersection type ~S do not match~:@>"
673 (type-specifier type
)))))))))
674 (or (maybe-array-type-dimensions type
)
675 (give-up-ir1-transform
676 "~@<don't know how to extract array dimensions from type ~S~:@>"
677 (type-specifier type
)))))
679 (defun conservative-array-type-complexp (type)
681 (array-type (array-type-complexp type
))
683 (let ((types (union-type-types type
)))
684 (aver (> (length types
) 1))
685 (let ((result (conservative-array-type-complexp (car types
))))
686 (dolist (type (cdr types
) result
)
687 (unless (eq (conservative-array-type-complexp type
) result
)
688 (return-from conservative-array-type-complexp
:maybe
))))))
689 ;; FIXME: intersection type
692 ;;; If we can tell the rank from the type info, use it instead.
693 (deftransform array-rank
((array))
694 (let ((array-type (lvar-type array
)))
695 (let ((dims (array-type-dimensions-or-give-up array-type
)))
698 ((eq t
(array-type-complexp array-type
))
699 '(%array-rank array
))
701 `(if (array-header-p array
)
705 ;;; If we know the dimensions at compile time, just use it. Otherwise,
706 ;;; if we can tell that the axis is in bounds, convert to
707 ;;; %ARRAY-DIMENSION (which just indirects the array header) or length
708 ;;; (if it's simple and a vector).
709 (deftransform array-dimension
((array axis
)
711 (unless (constant-lvar-p axis
)
712 (give-up-ir1-transform "The axis is not constant."))
713 ;; Dimensions may change thanks to ADJUST-ARRAY, so we need the
714 ;; conservative type.
715 (let ((array-type (lvar-conservative-type array
))
716 (axis (lvar-value axis
)))
717 (let ((dims (array-type-dimensions-or-give-up array-type
)))
719 (give-up-ir1-transform
720 "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime."))
721 (unless (> (length dims
) axis
)
722 (abort-ir1-transform "The array has dimensions ~S, ~W is too large."
725 (let ((dim (nth axis dims
)))
726 (cond ((integerp dim
)
729 (ecase (conservative-array-type-complexp array-type
)
731 '(%array-dimension array
0))
733 '(vector-length array
))
735 `(if (array-header-p array
)
736 (%array-dimension array axis
)
737 (vector-length array
)))))
739 '(%array-dimension array axis
)))))))
741 ;;; If the length has been declared and it's simple, just return it.
742 (deftransform length
((vector)
743 ((simple-array * (*))))
744 (let ((type (lvar-type vector
)))
745 (let ((dims (array-type-dimensions-or-give-up type
)))
746 (unless (and (listp dims
) (integerp (car dims
)))
747 (give-up-ir1-transform
748 "Vector length is unknown, must call LENGTH at runtime."))
751 ;;; All vectors can get their length by using VECTOR-LENGTH. If it's
752 ;;; simple, it will extract the length slot from the vector. It it's
753 ;;; complex, it will extract the fill pointer slot from the array
755 (deftransform length
((vector) (vector))
756 '(vector-length vector
))
758 ;;; If a simple array with known dimensions, then VECTOR-LENGTH is a
759 ;;; compile-time constant.
760 (deftransform vector-length
((vector))
761 (let ((vtype (lvar-type vector
)))
762 (let ((dim (first (array-type-dimensions-or-give-up vtype
))))
764 (give-up-ir1-transform))
765 (when (conservative-array-type-complexp vtype
)
766 (give-up-ir1-transform))
769 ;;; Again, if we can tell the results from the type, just use it.
770 ;;; Otherwise, if we know the rank, convert into a computation based
771 ;;; on array-dimension. We can wrap a TRULY-THE INDEX around the
772 ;;; multiplications because we know that the total size must be an
774 (deftransform array-total-size
((array)
776 (let ((array-type (lvar-type array
)))
777 (let ((dims (array-type-dimensions-or-give-up array-type
)))
779 (give-up-ir1-transform "can't tell the rank at compile time"))
781 (do ((form 1 `(truly-the index
782 (* (array-dimension array
,i
) ,form
)))
784 ((= i
(length dims
)) form
))
785 (reduce #'* dims
)))))
787 ;;; Only complex vectors have fill pointers.
788 (deftransform array-has-fill-pointer-p
((array))
789 (let ((array-type (lvar-type array
)))
790 (let ((dims (array-type-dimensions-or-give-up array-type
)))
791 (if (and (listp dims
) (not (= (length dims
) 1)))
793 (ecase (conservative-array-type-complexp array-type
)
799 (give-up-ir1-transform
800 "The array type is ambiguous; must call ~
801 ARRAY-HAS-FILL-POINTER-P at runtime.")))))))
803 ;;; Primitive used to verify indices into arrays. If we can tell at
804 ;;; compile-time or we are generating unsafe code, don't bother with
806 (deftransform %check-bound
((array dimension index
) * * :node node
)
807 (cond ((policy node
(= insert-array-bounds-checks
0))
809 ((not (constant-lvar-p dimension
))
810 (give-up-ir1-transform))
812 (let ((dim (lvar-value dimension
)))
813 ;; FIXME: Can SPEED > SAFETY weaken this check to INTEGER?
814 `(the (integer 0 (,dim
)) index
)))))
818 ;;; This checks to see whether the array is simple and the start and
819 ;;; end are in bounds. If so, it proceeds with those values.
820 ;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that %WITH-ARRAY-DATA
821 ;;; may be further optimized.
823 ;;; Given any ARRAY, bind DATA-VAR to the array's data vector and
824 ;;; START-VAR and END-VAR to the start and end of the designated
825 ;;; portion of the data vector. SVALUE and EVALUE are any start and
826 ;;; end specified to the original operation, and are factored into the
827 ;;; bindings of START-VAR and END-VAR. OFFSET-VAR is the cumulative
828 ;;; offset of all displacements encountered, and does not include
831 ;;; When FORCE-INLINE is set, the underlying %WITH-ARRAY-DATA form is
832 ;;; forced to be inline, overriding the ordinary judgment of the
833 ;;; %WITH-ARRAY-DATA DEFTRANSFORMs. Ordinarily the DEFTRANSFORMs are
834 ;;; fairly picky about their arguments, figuring that if you haven't
835 ;;; bothered to get all your ducks in a row, you probably don't care
836 ;;; that much about speed anyway! But in some cases it makes sense to
837 ;;; do type testing inside %WITH-ARRAY-DATA instead of outside, and
838 ;;; the DEFTRANSFORM can't tell that that's going on, so it can make
839 ;;; sense to use FORCE-INLINE option in that case.
840 (def!macro with-array-data
(((data-var array
&key offset-var
)
841 (start-var &optional
(svalue 0))
842 (end-var &optional
(evalue nil
))
843 &key force-inline check-fill-pointer
)
846 (once-only ((n-array array
)
847 (n-svalue `(the index
,svalue
))
848 (n-evalue `(the (or index null
) ,evalue
)))
849 (let ((check-bounds (policy env
(plusp insert-array-bounds-checks
))))
850 `(multiple-value-bind (,data-var
853 ,@(when offset-var
`(,offset-var
)))
854 (if (not (array-header-p ,n-array
))
855 (let ((,n-array
,n-array
))
856 (declare (type (simple-array * (*)) ,n-array
))
857 ,(once-only ((n-len (if check-fill-pointer
859 `(array-total-size ,n-array
)))
860 (n-end `(or ,n-evalue
,n-len
)))
862 `(if (<= 0 ,n-svalue
,n-end
,n-len
)
863 (values ,n-array
,n-svalue
,n-end
0)
864 ,(if check-fill-pointer
865 `(sequence-bounding-indices-bad-error ,n-array
,n-svalue
,n-evalue
)
866 `(array-bounding-indices-bad-error ,n-array
,n-svalue
,n-evalue
)))
867 `(values ,n-array
,n-svalue
,n-end
0))))
869 `(%with-array-data-macro
,n-array
,n-svalue
,n-evalue
870 :check-bounds
,check-bounds
871 :check-fill-pointer
,check-fill-pointer
)
872 (if check-fill-pointer
873 `(%with-array-data
/fp
,n-array
,n-svalue
,n-evalue
)
874 `(%with-array-data
,n-array
,n-svalue
,n-evalue
))))
877 ;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in
878 ;;; DEFTRANSFORMs and DEFUNs.
879 (def!macro %with-array-data-macro
(array
886 (with-unique-names (size defaulted-end data cumulative-offset
)
887 `(let* ((,size
,(if check-fill-pointer
889 `(array-total-size ,array
)))
890 (,defaulted-end
(or ,end
,size
)))
892 `((unless (<= ,start
,defaulted-end
,size
)
893 ,(if check-fill-pointer
894 `(sequence-bounding-indices-bad-error ,array
,start
,end
)
895 `(array-bounding-indices-bad-error ,array
,start
,end
)))))
896 (do ((,data
,array
(%array-data-vector
,data
))
897 (,cumulative-offset
0
898 (+ ,cumulative-offset
899 (%array-displacement
,data
))))
900 ((not (array-header-p ,data
))
901 (values (the (simple-array ,element-type
1) ,data
)
902 (the index
(+ ,cumulative-offset
,start
))
903 (the index
(+ ,cumulative-offset
,defaulted-end
))
904 (the index
,cumulative-offset
)))
905 (declare (type index
,cumulative-offset
))))))
907 (defun transform-%with-array-data
/muble
(array node check-fill-pointer
)
908 (let ((element-type (upgraded-element-type-specifier-or-give-up array
))
909 (type (lvar-type array
))
910 (check-bounds (policy node
(plusp insert-array-bounds-checks
))))
911 (if (and (array-type-p type
)
912 (not (array-type-complexp type
))
913 (listp (array-type-dimensions type
))
914 (not (null (cdr (array-type-dimensions type
)))))
915 ;; If it's a simple multidimensional array, then just return
916 ;; its data vector directly rather than going through
917 ;; %WITH-ARRAY-DATA-MACRO. SBCL doesn't generally generate
918 ;; code that would use this currently, but we have encouraged
919 ;; users to use WITH-ARRAY-DATA and we may use it ourselves at
920 ;; some point in the future for optimized libraries or
923 `(let* ((data (truly-the (simple-array ,element-type
(*))
924 (%array-data-vector array
)))
926 (real-end (or end len
)))
927 (unless (<= 0 start data-end lend
)
928 (sequence-bounding-indices-bad-error array start end
))
929 (values data
0 real-end
0))
930 `(let ((data (truly-the (simple-array ,element-type
(*))
931 (%array-data-vector array
))))
932 (values data
0 (or end
(length data
)) 0)))
933 `(%with-array-data-macro array start end
934 :check-fill-pointer
,check-fill-pointer
935 :check-bounds
,check-bounds
936 :element-type
,element-type
))))
938 ;; It might very well be reasonable to allow general ARRAY here, I
939 ;; just haven't tried to understand the performance issues involved.
940 ;; -- WHN, and also CSR 2002-05-26
941 (deftransform %with-array-data
((array start end
)
942 ((or vector simple-array
) index
(or index null
) t
)
945 :policy
(> speed space
))
946 "inline non-SIMPLE-vector-handling logic"
947 (transform-%with-array-data
/muble array node nil
))
948 (deftransform %with-array-data
/fp
((array start end
)
949 ((or vector simple-array
) index
(or index null
) t
)
952 :policy
(> speed space
))
953 "inline non-SIMPLE-vector-handling logic"
954 (transform-%with-array-data
/muble array node t
))
958 ;;; We convert all typed array accessors into AREF and %ASET with type
959 ;;; assertions on the array.
960 (macrolet ((define-bit-frob (reffer setter simplep
)
962 (define-source-transform ,reffer
(a &rest i
)
963 `(aref (the (,',(if simplep
'simple-array
'array
)
965 ,(mapcar (constantly '*) i
))
967 (define-source-transform ,setter
(a &rest i
)
968 `(%aset
(the (,',(if simplep
'simple-array
'array
)
970 ,(cdr (mapcar (constantly '*) i
)))
972 (define-bit-frob sbit %sbitset t
)
973 (define-bit-frob bit %bitset nil
))
974 (macrolet ((define-frob (reffer setter type
)
976 (define-source-transform ,reffer
(a i
)
977 `(aref (the ,',type
,a
) ,i
))
978 (define-source-transform ,setter
(a i v
)
979 `(%aset
(the ,',type
,a
) ,i
,v
)))))
980 (define-frob svref %svset simple-vector
)
981 (define-frob schar %scharset simple-string
)
982 (define-frob char %charset string
))
984 (macrolet (;; This is a handy macro for computing the row-major index
985 ;; given a set of indices. We wrap each index with a call
986 ;; to %CHECK-BOUND to ensure that everything works out
987 ;; correctly. We can wrap all the interior arithmetic with
988 ;; TRULY-THE INDEX because we know the resultant
989 ;; row-major index must be an index.
990 (with-row-major-index ((array indices index
&optional new-value
)
992 `(let (n-indices dims
)
993 (dotimes (i (length ,indices
))
994 (push (make-symbol (format nil
"INDEX-~D" i
)) n-indices
)
995 (push (make-symbol (format nil
"DIM-~D" i
)) dims
))
996 (setf n-indices
(nreverse n-indices
))
997 (setf dims
(nreverse dims
))
998 `(lambda (,',array
,@n-indices
999 ,@',(when new-value
(list new-value
)))
1000 (let* (,@(let ((,index -
1))
1001 (mapcar (lambda (name)
1002 `(,name
(array-dimension
1009 (do* ((dims dims
(cdr dims
))
1010 (indices n-indices
(cdr indices
))
1011 (last-dim nil
(car dims
))
1012 (form `(%check-bound
,',array
1024 ((null (cdr dims
)) form
)))))
1027 ;; Just return the index after computing it.
1028 (deftransform array-row-major-index
((array &rest indices
))
1029 (with-row-major-index (array indices index
)
1032 ;; Convert AREF and %ASET into a HAIRY-DATA-VECTOR-REF (or
1033 ;; HAIRY-DATA-VECTOR-SET) with the set of indices replaced with the an
1034 ;; expression for the row major index.
1035 (deftransform aref
((array &rest indices
))
1036 (with-row-major-index (array indices index
)
1037 (hairy-data-vector-ref array index
)))
1039 (deftransform %aset
((array &rest stuff
))
1040 (let ((indices (butlast stuff
)))
1041 (with-row-major-index (array indices index new-value
)
1042 (hairy-data-vector-set array index new-value
)))))
1044 ;; For AREF of vectors we do the bounds checking in the callee. This
1045 ;; lets us do a significantly more efficient check for simple-arrays
1046 ;; without bloating the code. If we already know the type of the array
1047 ;; with sufficient precision, skip directly to DATA-VECTOR-REF.
1048 (deftransform aref
((array index
) (t t
) * :node node
)
1049 (let* ((type (lvar-type array
))
1050 (element-ctype (array-type-upgraded-element-type type
)))
1052 ((and (array-type-p type
)
1053 (null (array-type-complexp type
))
1054 (not (eql element-ctype
*wild-type
*))
1055 (eql (length (array-type-dimensions type
)) 1))
1056 (let* ((declared-element-ctype (array-type-declared-element-type type
))
1058 `(data-vector-ref array
1059 (%check-bound array
(array-dimension array
0) index
))))
1060 (if (type= declared-element-ctype element-ctype
)
1062 `(the ,(type-specifier declared-element-ctype
) ,bare-form
))))
1063 ((policy node
(zerop insert-array-bounds-checks
))
1064 `(hairy-data-vector-ref array index
))
1065 (t `(hairy-data-vector-ref/check-bounds array index
)))))
1067 (deftransform %aset
((array index new-value
) (t t t
) * :node node
)
1068 (if (policy node
(zerop insert-array-bounds-checks
))
1069 `(hairy-data-vector-set array index new-value
)
1070 `(hairy-data-vector-set/check-bounds array index new-value
)))
1072 ;;; But if we find out later that there's some useful type information
1073 ;;; available, switch back to the normal one to give other transforms
1075 (macrolet ((define (name transform-to extra extra-type
)
1076 (declare (ignore extra-type
))
1077 `(deftransform ,name
((array index
,@extra
))
1078 (let* ((type (lvar-type array
))
1079 (element-type (array-type-upgraded-element-type type
))
1080 (declared-type (array-type-declared-element-type type
)))
1081 ;; If an element type has been declared, we want to
1082 ;; use that information it for type checking (even
1083 ;; if the access can't be optimized due to the array
1084 ;; not being simple).
1085 (when (and (eql element-type
*wild-type
*)
1086 ;; This type logic corresponds to the special
1087 ;; case for strings in HAIRY-DATA-VECTOR-REF
1088 ;; (generic/vm-tran.lisp)
1089 (not (csubtypep type
(specifier-type 'simple-string
))))
1090 (when (or (not (array-type-p type
))
1091 ;; If it's a simple array, we might be able
1092 ;; to inline the access completely.
1093 (not (null (array-type-complexp type
))))
1094 (give-up-ir1-transform
1095 "Upgraded element type of array is not known at compile time.")))
1097 ``(truly-the ,declared-type
1098 (,',transform-to array
1100 (array-dimension array
0)
1102 (the ,declared-type
,@',extra
)))
1103 ``(the ,declared-type
1104 (,',transform-to array
1106 (array-dimension array
0)
1108 (define hairy-data-vector-ref
/check-bounds
1109 hairy-data-vector-ref nil nil
)
1110 (define hairy-data-vector-set
/check-bounds
1111 hairy-data-vector-set
(new-value) (*)))
1113 ;;; Just convert into a HAIRY-DATA-VECTOR-REF (or
1114 ;;; HAIRY-DATA-VECTOR-SET) after checking that the index is inside the
1115 ;;; array total size.
1116 (deftransform row-major-aref
((array index
))
1117 `(hairy-data-vector-ref array
1118 (%check-bound array
(array-total-size array
) index
)))
1119 (deftransform %set-row-major-aref
((array index new-value
))
1120 `(hairy-data-vector-set array
1121 (%check-bound array
(array-total-size array
) index
)
1124 ;;;; bit-vector array operation canonicalization
1126 ;;;; We convert all bit-vector operations to have the result array
1127 ;;;; specified. This allows any result allocation to be open-coded,
1128 ;;;; and eliminates the need for any VM-dependent transforms to handle
1131 (macrolet ((def (fun)
1133 (deftransform ,fun
((bit-array-1 bit-array-2
1134 &optional result-bit-array
)
1135 (bit-vector bit-vector
&optional null
) *
1136 :policy
(>= speed space
))
1137 `(,',fun bit-array-1 bit-array-2
1138 (make-array (array-dimension bit-array-1
0) :element-type
'bit
)))
1139 ;; If result is T, make it the first arg.
1140 (deftransform ,fun
((bit-array-1 bit-array-2 result-bit-array
)
1141 (bit-vector bit-vector
(eql t
)) *)
1142 `(,',fun bit-array-1 bit-array-2 bit-array-1
)))))
1154 ;;; Similar for BIT-NOT, but there is only one arg...
1155 (deftransform bit-not
((bit-array-1 &optional result-bit-array
)
1156 (bit-vector &optional null
) *
1157 :policy
(>= speed space
))
1158 '(bit-not bit-array-1
1159 (make-array (array-dimension bit-array-1
0) :element-type
'bit
)))
1160 (deftransform bit-not
((bit-array-1 result-bit-array
)
1161 (bit-vector (eql t
)))
1162 '(bit-not bit-array-1 bit-array-1
))
1164 ;;; Pick off some constant cases.
1165 (defoptimizer (array-header-p derive-type
) ((array))
1166 (let ((type (lvar-type array
)))
1167 (cond ((not (array-type-p type
))
1168 ;; FIXME: use analogue of ARRAY-TYPE-DIMENSIONS-OR-GIVE-UP
1171 (let ((dims (array-type-dimensions type
)))
1172 (cond ((csubtypep type
(specifier-type '(simple-array * (*))))
1174 (specifier-type 'null
))
1175 ((and (listp dims
) (/= (length dims
) 1))
1176 ;; multi-dimensional array, will have a header
1177 (specifier-type '(eql t
)))
1178 ((eql (array-type-complexp type
) t
)
1179 (specifier-type '(eql t
)))