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
)))
128 (lvar-type new-value
))
130 ;;; Return true if ARG is NIL, or is a constant-lvar whose
131 ;;; value is NIL, false otherwise.
132 (defun unsupplied-or-nil (arg)
133 (declare (type (or lvar null
) arg
))
135 (and (constant-lvar-p arg
)
136 (not (lvar-value arg
)))))
138 (defun supplied-and-true (arg)
140 (constant-lvar-p arg
)
144 ;;;; DERIVE-TYPE optimizers
146 (defun derive-aref-type (array)
147 (multiple-value-bind (uaet other
)
148 (array-type-upgraded-element-type (lvar-type array
))
151 (deftransform array-in-bounds-p
((array &rest subscripts
))
153 (flet ((give-up (&optional reason
)
154 (cond ((= (length subscripts
) 1)
155 (let ((arg (sb!xc
:gensym
)))
156 `(lambda (array ,arg
)
157 (and (typep ,arg
'(and fixnum unsigned-byte
))
158 (< ,arg
(array-dimension array
0))))))
160 (give-up-ir1-transform
162 "~@<lower array bounds unknown or negative and upper bounds not ~
165 (integerp x
))) ; might be NIL or *
166 (let ((dimensions (catch-give-up-ir1-transform
167 ((array-type-dimensions-or-give-up
168 (lvar-conservative-type array
))
170 (give-up (car args
)))))
171 ;; Might be *. (Note: currently this is never true, because the type
172 ;; derivation infers the rank from the call to ARRAY-IN-BOUNDS-P, but
173 ;; let's keep this future proof.)
174 (when (eq '* dimensions
)
175 (give-up "array bounds unknown"))
176 ;; shortcut for zero dimensions
177 (when (some (lambda (dim)
178 (and (bound-known-p dim
) (zerop dim
)))
181 ;; we first collect the subscripts LVARs' bounds and see whether
182 ;; we can already decide on the result of the optimization without
183 ;; even taking a look at the dimensions.
184 (flet ((subscript-bounds (subscript)
185 (let* ((type1 (lvar-type subscript
))
186 (type2 (if (csubtypep type1
(specifier-type 'integer
))
187 (weaken-integer-type type1
:range-only t
)
189 (low (if (integer-type-p type2
)
190 (numeric-type-low type2
)
192 (high (numeric-type-high type2
)))
194 ((and (or (not (bound-known-p low
)) (minusp low
))
195 (or (not (bound-known-p high
)) (not (minusp high
))))
196 ;; can't be sure about the lower bound and the upper bound
197 ;; does not give us a definite clue either.
199 ((and (bound-known-p high
) (minusp high
))
200 (return nil
)) ; definitely below lower bound (zero).
203 (let* ((subscripts-bounds (mapcar #'subscript-bounds subscripts
))
204 (subscripts-lower-bound (mapcar #'car subscripts-bounds
))
205 (subscripts-upper-bound (mapcar #'cdr subscripts-bounds
))
207 (mapcar (lambda (low high dim
)
209 ;; first deal with infinite bounds
210 ((some (complement #'bound-known-p
) (list low high dim
))
211 (when (and (bound-known-p dim
) (bound-known-p low
) (<= dim low
))
213 ;; now we know all bounds
217 (aver (not (minusp low
)))
221 subscripts-lower-bound
222 subscripts-upper-bound
224 (if (eql in-bounds
(length dimensions
))
228 (defoptimizer (aref derive-type
) ((array &rest subscripts
))
229 (declare (ignore subscripts
))
230 (derive-aref-type array
))
232 (defoptimizer ((setf aref
) derive-type
) ((new-value array
&rest subscripts
))
233 (declare (ignore subscripts
))
234 (assert-new-value-type new-value array
))
236 (macrolet ((define (name)
237 `(defoptimizer (,name derive-type
) ((array index
))
238 (declare (ignore 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 (declare (ignore index offset
))
247 (derive-aref-type array
))
249 (defoptimizer (vector-pop derive-type
) ((array))
250 (derive-aref-type array
))
252 (macrolet ((define (name)
253 `(defoptimizer (,name derive-type
) ((array index new-value
))
254 (declare (ignore index
))
255 (assert-new-value-type new-value array
))))
256 (define hairy-data-vector-set
)
257 (define hairy-data-vector-set
/check-bounds
)
258 (define data-vector-set
))
261 (defoptimizer (data-vector-set-with-offset derive-type
) ((array index offset new-value
))
262 (declare (ignore index offset
))
263 (assert-new-value-type new-value array
))
265 ;;; Figure out the type of the data vector if we know the argument
267 (defun derive-%with-array-data
/mumble-type
(array)
268 (let ((atype (lvar-type array
)))
269 (when (array-type-p atype
)
271 `(simple-array ,(type-specifier
272 (array-type-specialized-element-type atype
))
274 (defoptimizer (%with-array-data derive-type
) ((array start end
))
275 (declare (ignore start end
))
276 (derive-%with-array-data
/mumble-type array
))
277 (defoptimizer (%with-array-data
/fp derive-type
) ((array start end
))
278 (declare (ignore start end
))
279 (derive-%with-array-data
/mumble-type array
))
281 (defoptimizer (row-major-aref derive-type
) ((array index
))
282 (declare (ignore index
))
283 (derive-aref-type array
))
285 (defoptimizer (%set-row-major-aref derive-type
) ((array index new-value
))
286 (declare (ignore index
))
287 (assert-new-value-type new-value array
))
289 (defun derive-make-array-type (dims element-type adjustable
290 fill-pointer displaced-to
)
291 (let* ((simple (and (unsupplied-or-nil adjustable
)
292 (unsupplied-or-nil displaced-to
)
293 (unsupplied-or-nil fill-pointer
)))
295 (or `(,(if simple
'simple-array
'array
)
296 ,(cond ((not element-type
) t
)
297 ((ctype-p element-type
)
298 (type-specifier element-type
))
299 ((constant-lvar-p element-type
)
300 (let ((ctype (careful-specifier-type
301 (lvar-value element-type
))))
303 ((or (null ctype
) (contains-unknown-type-p ctype
)) '*)
304 (t (sb!xc
:upgraded-array-element-type
305 (lvar-value element-type
))))))
308 ,(cond ((constant-lvar-p dims
)
309 (let* ((val (lvar-value dims
))
310 (cdims (ensure-list val
)))
314 ((csubtypep (lvar-type dims
)
315 (specifier-type 'integer
))
320 (if (and (not simple
)
321 (or (supplied-and-true adjustable
)
322 (supplied-and-true displaced-to
)
323 (supplied-and-true fill-pointer
)))
324 (careful-specifier-type `(and ,spec
(not simple-array
)))
325 (careful-specifier-type spec
))))
327 (defoptimizer (make-array derive-type
)
328 ((dims &key element-type adjustable fill-pointer displaced-to
330 (derive-make-array-type dims element-type adjustable
331 fill-pointer displaced-to
))
333 (defoptimizer (%make-array derive-type
)
334 ((dims widetag n-bits
&key adjustable fill-pointer displaced-to
336 (declare (ignore n-bits
))
337 (let ((saetp (and (constant-lvar-p widetag
)
338 (find (lvar-value widetag
)
339 sb
!vm
:*specialized-array-element-type-properties
*
340 :key
#'sb
!vm
:saetp-typecode
))))
341 (derive-make-array-type dims
(if saetp
342 (sb!vm
:saetp-ctype saetp
)
344 adjustable fill-pointer displaced-to
)))
349 ;;; Convert VECTOR into a MAKE-ARRAY.
350 (define-source-transform vector
(&rest elements
)
351 `(make-array ,(length elements
) :initial-contents
(list ,@elements
)))
353 ;;; Just convert it into a MAKE-ARRAY.
354 (deftransform make-string
((length &key
355 (element-type 'character
)
357 #.
*default-init-char-form
*)))
358 `(the simple-string
(make-array (the index length
)
359 :element-type element-type
360 ,@(when initial-element
361 '(:initial-element initial-element
)))))
363 ;; Traverse the :INTIAL-CONTENTS argument to an array constructor call,
364 ;; changing the skeleton of the data to be constructed by calls to LIST
365 ;; and wrapping some declarations around each array cell's constructor.
366 ;; In general, if we fail to optimize out the materialization
367 ;; of initial-contents as distinct from the array itself, we prefer VECTOR
368 ;; over LIST due to the smaller overhead (except for <= 1 item).
369 ;; If a macro is involved, expand it before traversing.
370 ;; Known limitations:
371 ;; - inline functions whose behavior is merely to call LIST don't work
372 ;; e.g. :INITIAL-CONTENTS (MY-LIST a b) ; where MY-LIST is inline
373 ;; ; and effectively just (LIST ...)
374 (defun rewrite-initial-contents (rank initial-contents env
)
375 ;; If FORM is constant to begin with, we don't want to pessimize it
376 ;; by turning it into a non-literal. That would happen because when
377 ;; optimizing `#(#(foo bar) #(,x ,y)) we convert the whole expression
378 ;; into (VECTOR 'FOO 'BAR X Y), whereas in the unidimensional case
379 ;; it never makes sense to turn #(FOO BAR) into (VECTOR 'FOO 'BAR).
380 (when (or (and (= rank
1) (sb!xc
:constantp initial-contents env
))
381 ;; If you inhibit inlining these - game over.
382 (fun-lexically-notinline-p 'vector env
)
383 (fun-lexically-notinline-p 'list env
)
384 (fun-lexically-notinline-p 'list
* env
))
385 (return-from rewrite-initial-contents
(values nil nil
)))
386 (let ((dimensions (make-array rank
:initial-element nil
))
388 (named-let recurse
((form (sb!xc
:macroexpand initial-contents env
))
390 (flet ((make-list-ctor (tail &optional
(prefix nil prefixp
) &aux val
)
391 (when (and (sb!xc
:constantp tail
)
392 (or (proper-list-p (setq val
(constant-form-value tail env
)))
393 (and (vectorp val
) (not prefixp
))))
396 (append (butlast prefix
)
397 (map 'list
(lambda (x) (list 'quote x
)) val
)))))))
398 ;; Express quasiquotation using only LIST, not LIST*.
399 ;; e.g. `(,A ,B X Y) -> (LIST* A B '(X Y)) -> (LIST A B 'X 'Y)
400 (if (typep form
'(cons (eql list
*) list
))
401 (let* ((cdr (cdr form
)) (last (last cdr
)))
402 (when (null (cdr last
))
403 (make-list-ctor (car last
) cdr
)))
404 (make-list-ctor form
)))
405 (unless (and (typep form
'(cons (member list vector
)))
406 (do ((items (cdr form
))
407 (length 0 (1+ length
))
408 (fun (let ((axis (the (mod #.array-rank-limit
) (1+ axis
))))
410 (lambda (item) (push item output
))
411 (lambda (item) (recurse item axis
))))))
412 ;; FIXME: warn if the nesting is indisputably wrong
413 ;; such as `((,x ,x) (,x ,x ,x)).
416 (if (aref dimensions axis
)
417 (eql length
(aref dimensions axis
))
418 (setf (aref dimensions axis
) length
))))
419 (declare (type index length
))
420 (funcall fun
(pop items
))))
421 (return-from rewrite-initial-contents
(values nil nil
))))
422 (when (some #'null dimensions
)
423 ;; Unless it is the rightmost axis, a 0-length subsequence
424 ;; causes a NIL dimension. Give up if that happens.
425 (return-from rewrite-initial-contents
(values nil nil
)))
426 (setq output
(nreverse output
))
428 ;; If the unaltered INITIAL-CONTENTS were constant, then the flattened
429 ;; form must be too. Turning it back to a self-evaluating object
430 ;; is essential to avoid compile-time blow-up on huge vectors.
431 (if (sb!xc
:constantp initial-contents env
)
432 (map 'vector
(lambda (x) (constant-form-value x env
)) output
)
433 (let ((f (if (singleton-p output
) 'list
'vector
)))
434 `(locally (declare (notinline ,f
))
435 (,f
,@(mapcar (lambda (x)
436 (cond ((and (symbolp x
)
438 1 (sb!xc
:macroexpand-1 x env
))))
440 ((sb!xc
:constantp x env
)
441 `',(constant-form-value x env
))
443 `(locally (declare (inline ,f
)) ,x
))))
445 (coerce dimensions
'list
))))
447 ;;; Prevent open coding :INITIAL-CONTENTS arguments, so that we
448 ;;; can pick them apart in the DEFTRANSFORMS.
449 ;;; (MAKE-ARRAY (LIST dim ...)) for rank != 1 is transformed now.
450 ;;; Waiting around to see if IR1 can deduce that the dims are of type LIST
451 ;;; is ineffective, because by then it's too late to flatten the initial
452 ;;; contents using the correct array rank.
453 ;;; We explicitly avoid handling non-simple arrays (uni- or multi-dimensional)
454 ;;; in this path, mainly due to complications in picking the right widetag.
455 (define-source-transform make-array
(dims-form &rest rest
&environment env
456 &aux dims dims-constp
)
457 (cond ((and (sb!xc
:constantp dims-form env
)
458 (listp (setq dims
(constant-form-value dims-form env
)))
459 (not (singleton-p dims
))
460 (every (lambda (x) (typep x
'index
)) dims
))
461 (setq dims-constp t
))
462 ((and (cond ((typep (setq dims
(sb!xc
:macroexpand dims-form env
))
464 (setq dims
(cdr dims
))
466 ;; `(,X 2 1) -> (LIST* X '(2 1)) for example
467 ((typep dims
'(cons (eql list
*) cons
))
468 (let ((last (car (last dims
))))
469 (when (sb!xc
:constantp last env
)
470 (let ((lastval (constant-form-value last env
)))
471 (when (listp lastval
)
472 (setq dims
(append (butlast (cdr dims
)) lastval
))
475 (not (singleton-p dims
)))
476 ;; If you spell '(2 2) as (LIST 2 2), it is constant for purposes of MAKE-ARRAY.
477 (when (every (lambda (x) (sb!xc
:constantp x env
)) dims
)
478 (let ((values (mapcar (lambda (x) (constant-form-value x env
)) dims
)))
479 (when (every (lambda (x) (typep x
'index
)) values
)
480 (setq dims values dims-constp t
)))))
482 ;; Regardless of dimension, it is always good to flatten :INITIAL-CONTENTS
483 ;; if we can, ensuring that we convert `(,X :A :B) = (LIST* X '(:A :B))
484 ;; into (VECTOR X :A :B) which makes it cons less if not optimized,
485 ;; or cons not at all (not counting the destination array) if optimized.
486 ;; There is no need to transform dimensions of '(<N>) to the integer N.
487 ;; The IR1 transform for list-shaped dims will figure it out.
488 (binding* ((contents (and (evenp (length rest
)) (getf rest
:initial-contents
))
490 ;; N-DIMS = 1 can be "technically" wrong, but it doesn't matter.
491 (data (rewrite-initial-contents 1 contents env
) :exit-if-null
))
492 (setf rest
(copy-list rest
) (getf rest
:initial-contents
) data
)
493 (return-from make-array
`(make-array ,dims-form
,@rest
)))
494 (return-from make-array
(values nil t
))))
495 ;; So now we know that this is a multi-dimensional (or 0-dimensional) array.
496 ;; Parse keywords conservatively, rejecting anything that makes it non-simple,
497 ;; and accepting only a pattern that is likely to occur in practice.
498 ;; e.g we give up on a duplicate keywords rather than bind ignored temps.
499 (let* ((unsupplied '#:unsupplied
) (et unsupplied
) et-constp et-binding
500 contents element adjustable keys data-dims
)
501 (unless (loop (if (null rest
) (return t
))
502 (if (or (atom rest
) (atom (cdr rest
))) (return nil
))
508 (unless (eq et unsupplied
) (return nil
))
509 (setq et
(car v
) et-constp
(sb!xc
:constantp et env
)))
511 (when (or contents element
) (return nil
))
514 (when (or contents element
) (return nil
))
515 (if (not dims
) ; If 0-dimensional, use :INITIAL-ELEMENT instead
516 (setq k
:initial-element element v
)
518 (:adjustable
; reject if anything other than literal NIL
519 (when (or adjustable
(car v
)) (return nil
))
522 ;; Reject :FILL-POINTER, :DISPLACED-{TO,INDEX-OFFSET},
523 ;; and non-literal keywords.
525 (unless (member k
'(:adjustable
))
526 (setq keys
(nconc keys
(list k
(car v
)))))))
527 (return-from make-array
(values nil t
)))
529 (multiple-value-bind (data shape
)
530 (rewrite-initial-contents (length dims
) (car contents
) env
)
531 (cond (shape ; initial-contents will be part of the vector allocation
532 ;; and we aren't messing up keyword arg order.
533 (when (and dims-constp
(not (equal shape dims
)))
534 ;; This will become a runtime error if the code is executed.
535 (warn "array dimensions are ~A but :INITIAL-CONTENTS dimensions are ~A"
537 (setf data-dims shape
(getf keys
:initial-contents
) data
))
538 (t ; contents could not be flattened
539 ;; Preserve eval order. The only keyword arg to worry about
540 ;; is :ELEMENT-TYPE. See also the remark at DEFKNOWN FILL-ARRAY.
541 (when (and (eq (car keys
) :element-type
) (not et-constp
))
542 (let ((et-temp (make-symbol "ET")))
543 (setf et-binding
`((,et-temp
,et
)) (cadr keys
) et-temp
)))
544 (remf keys
:initial-contents
)))))
545 (let* ((axis-bindings
547 (loop for d in dims for i from
0
548 collect
(list (make-symbol (format nil
"D~D" i
))
550 (dims (if axis-bindings
(mapcar #'car axis-bindings
) dims
))
551 (size (make-symbol "SIZE"))
553 `(truly-the (simple-array
554 ,(cond ((eq et unsupplied
) t
)
555 (et-constp (constant-form-value et env
))
557 ,(if dims-constp dims
(length dims
)))
559 ,@(sb!vm
::make-array-header-inits
560 `(make-array ,size
,@keys
) size dims
)))))
561 `(let* (,@axis-bindings
,@et-binding
(,size
(the index
(* ,@dims
))))
562 ,(cond ((or (not contents
) (and dims-constp
(equal dims data-dims
)))
563 ;; If no :initial-contents, or definitely correct shape,
564 ;; then just call the constructor.
566 (data-dims ; data are flattened
567 ;; original shape must be asserted to be correct
568 ;; Arguably if the contents have a constant shape,
569 ;; we could cast each individual dimension in its binding form,
570 ;; i.e. (LET* ((#:D0 (THE (EQL <n>) dimension0)) ...)
571 ;; but it seems preferable to imply that the initial contents
572 ;; are wrongly shaped rather than that the array is.
573 `(sb!kernel
::check-array-shape
,alloc-form
',data-dims
))
574 (t ; could not parse the data
575 `(fill-array ,(car contents
) ,alloc-form
)))))))
577 (define-source-transform coerce
(x type
&environment env
)
578 (if (and (sb!xc
:constantp type env
)
580 (memq (car x
) '(sb!impl
::|List| list
581 sb
!impl
::|Vector| vector
)))
582 (let* ((type (constant-form-value type env
))
583 (length (1- (length x
)))
584 (ctype (careful-values-specifier-type type
)))
585 (if (csubtypep ctype
(specifier-type '(array * (*))))
586 (multiple-value-bind (type element-type upgraded had-dimensions
)
587 (simplify-vector-type ctype
)
588 (declare (ignore type upgraded
))
593 ,@(and (not (eq element-type
*universal-type
*))
594 (not (eq element-type
*wild-type
*))
595 `(:element-type
',(type-specifier element-type
))))))
599 ;;; This baby is a bit of a monster, but it takes care of any MAKE-ARRAY
600 ;;; call which creates a vector with a known element type -- and tries
601 ;;; to do a good job with all the different ways it can happen.
602 (defun transform-make-array-vector (length element-type initial-element
603 initial-contents call
604 &key adjustable fill-pointer
)
605 (let* ((c-length (if (lvar-p length
)
606 (if (constant-lvar-p length
) (lvar-value length
))
608 (complex (cond ((and (or
610 (and (constant-lvar-p fill-pointer
)
611 (null (lvar-value fill-pointer
))))
615 (constant-lvar-p adjustable
)
616 (null (lvar-value adjustable
)))))
618 ((and (constant-lvar-p adjustable
)
619 (lvar-value adjustable
)))
621 (constant-lvar-p fill-pointer
)
622 (lvar-value fill-pointer
)))
624 ;; Deciding between complex and simple at
625 ;; run-time would be too much hassle
626 (give-up-ir1-transform))))
627 (elt-spec (if element-type
628 (lvar-value element-type
) ; enforces const-ness.
630 (elt-ctype (ir1-transform-specifier-type elt-spec
))
631 (saetp (if (unknown-type-p elt-ctype
)
632 (give-up-ir1-transform "~S is an unknown type: ~S"
633 :element-type elt-spec
)
634 (find-saetp-by-ctype elt-ctype
)))
635 (default-initial-element (sb!vm
:saetp-initial-element-default saetp
))
636 (n-bits (sb!vm
:saetp-n-bits saetp
))
637 (typecode (sb!vm
:saetp-typecode saetp
))
638 (n-pad-elements (sb!vm
:saetp-n-pad-elements saetp
))
641 (ceiling (* (+ c-length n-pad-elements
) n-bits
)
643 (let ((padded-length-form (if (zerop n-pad-elements
)
645 `(+ length
,n-pad-elements
))))
648 ((>= n-bits sb
!vm
:n-word-bits
)
649 `(* ,padded-length-form
651 ,(the fixnum
(/ n-bits sb
!vm
:n-word-bits
))))
653 (let ((n-elements-per-word (/ sb
!vm
:n-word-bits n-bits
)))
654 (declare (type index n-elements-per-word
)) ; i.e., not RATIO
655 `(ceiling (truly-the index
,padded-length-form
)
656 ,n-elements-per-word
)))))))
658 `(simple-array ,(sb!vm
:saetp-specifier saetp
) (,(or c-length
'*))))
661 `(and (array ,(sb!vm
:saetp-specifier saetp
) (*))
664 ,(sb!vm
:saetp-specifier saetp
) (,(or c-length
'*)))))
665 (header-form (and complex
666 `(make-array-header ,(or (sb!vm
:saetp-complex-typecode saetp
)
667 sb
!vm
:complex-vector-widetag
) 1)))
669 `(truly-the ,data-result-spec
670 (allocate-vector ,typecode
671 ;; If LENGTH is a singleton list,
672 ;; we want to avoid reading it.
673 (the index
,(or c-length
'length
))
675 (flet ((eliminate-keywords ()
676 (eliminate-keyword-args
678 '((:element-type element-type
)
679 (:initial-contents initial-contents
)
680 (:initial-element initial-element
)
681 (:adjustable adjustable
)
682 (:fill-pointer fill-pointer
))))
683 (with-alloc-form (&optional data-wrapper
)
686 (csubtypep (lvar-type fill-pointer
) (specifier-type 'index
))
687 (not (types-equal-or-intersect (lvar-type fill-pointer
)
688 (specifier-type `(integer 0 ,c-length
)))))
689 (compiler-warn "Invalid fill-pointer ~s for a vector of length ~s."
690 (type-specifier (lvar-type fill-pointer
))
692 (give-up-ir1-transform))
694 (let* ((constant-fill-pointer-p (constant-lvar-p fill-pointer
))
695 (fill-pointer-value (and constant-fill-pointer-p
696 (lvar-value fill-pointer
))))
697 `(let* ((header ,header-form
)
698 (data ,data-alloc-form
)
699 (data ,(or data-wrapper
'data
))
700 (length (the index
,(or c-length
'length
))))
701 (setf (%array-fill-pointer header
)
702 ,(cond ((eq fill-pointer-value t
)
706 (not constant-fill-pointer-p
))
707 `(cond ((or (eq fill-pointer t
)
710 ((> fill-pointer length
)
711 (error "Invalid fill-pointer ~a" fill-pointer
))
716 (setf (%array-fill-pointer-p header
)
718 `(and fill-pointer t
)))
719 (setf (%array-available-elements header
) length
)
720 (setf (%array-data header
) data
)
721 (setf (%array-displaced-p header
) nil
)
722 (setf (%array-displaced-from header
) nil
)
723 (setf (%array-dimension header
0) length
)
724 (truly-the ,result-spec header
))))
726 (subst data-alloc-form
'data data-wrapper
))
729 (cond ((and initial-element initial-contents
)
730 (abort-ir1-transform "Both ~S and ~S specified."
731 :initial-contents
:initial-element
))
733 ;; :INITIAL-CONTENTS (LIST ...), (VECTOR ...) and `(1 1 ,x) with a
735 ((and initial-contents c-length
736 (lvar-matches initial-contents
737 ;; FIXME: probably don't need all 4 of these now?
738 :fun-names
'(list vector
739 sb
!impl
::|List| sb
!impl
::|Vector|
)
740 :arg-count c-length
))
741 (let ((parameters (eliminate-keywords))
742 (elt-vars (make-gensym-list c-length
))
743 (lambda-list '(length)))
744 (splice-fun-args initial-contents
:any c-length
)
745 (dolist (p parameters
)
748 (if (eq p
'initial-contents
)
751 `(lambda ,lambda-list
752 (declare (type ,elt-spec
,@elt-vars
)
753 (ignorable ,@lambda-list
))
755 `(initialize-vector data
,@elt-vars
)))))
757 ;; constant :INITIAL-CONTENTS and LENGTH
758 ((and initial-contents c-length
759 (constant-lvar-p initial-contents
)
760 ;; As a practical matter, the initial-contents should not be
761 ;; too long, otherwise the compiler seems to spend forever
762 ;; compiling the lambda with one parameter per item.
763 ;; To make matters worse, the time grows superlinearly,
764 ;; and it's not entirely obvious that passing a constant array
765 ;; of 100x100 things is responsible for such an explosion.
766 (<= (length (lvar-value initial-contents
)) 1000))
767 (let ((contents (lvar-value initial-contents
)))
768 (unless (= c-length
(length contents
))
769 (abort-ir1-transform "~S has ~S elements, vector length is ~S."
770 :initial-contents
(length contents
) c-length
))
771 (let ((lambda-list `(length ,@(eliminate-keywords))))
772 `(lambda ,lambda-list
773 (declare (ignorable ,@lambda-list
))
775 `(initialize-vector data
776 ,@(map 'list
(lambda (elt)
777 `(the ,elt-spec
',elt
))
780 ;; any other :INITIAL-CONTENTS
782 (let ((lambda-list `(length ,@(eliminate-keywords))))
783 `(lambda ,lambda-list
784 (declare (ignorable ,@lambda-list
))
785 (unless (= (length initial-contents
) ,(or c-length
'length
))
786 (error "~S has ~D elements, vector length is ~D."
787 :initial-contents
(length initial-contents
)
788 ,(or c-length
'length
)))
790 `(replace data initial-contents
)))))
792 ;; :INITIAL-ELEMENT, not EQL to the default
793 ((and initial-element
794 (or (not (constant-lvar-p initial-element
))
795 (not (eql default-initial-element
(lvar-value initial-element
)))))
796 (let ((lambda-list `(length ,@(eliminate-keywords)))
797 (init (if (constant-lvar-p initial-element
)
798 (list 'quote
(lvar-value initial-element
))
800 `(lambda ,lambda-list
801 (declare (ignorable ,@lambda-list
))
803 `(fill data
(the ,elt-spec
,init
))))))
805 ;; just :ELEMENT-TYPE, or maybe with :INITIAL-ELEMENT EQL to the
809 (and (and (testable-type-p elt-ctype
)
810 (neq elt-ctype
*empty-type
*)
811 (not (ctypep default-initial-element elt-ctype
)))
812 ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE
813 ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If
814 ;; INITIAL-ELEMENT is not supplied, the consequences of later
815 ;; reading an uninitialized element of new-array are undefined,"
816 ;; so this could be legal code as long as the user plans to
817 ;; write before he reads, and if he doesn't we're free to do
818 ;; anything we like. But in case the user doesn't know to write
819 ;; elements before he reads elements (or to read manuals before
820 ;; he writes code:-), we'll signal a STYLE-WARNING in case he
821 ;; didn't realize this.
824 (compiler-warn "~S ~S is not a ~S"
825 :initial-element default-initial-element
827 ;; For the default initial element, only warn if
828 ;; any array elements are initialized using it.
829 ((and (not (eql c-length
0))
830 ;; If it's coming from the source transform,
831 ;; then fill-array means it was supplied initial-contents
832 (not (lvar-matches-calls (combination-lvar call
)
833 '(make-array-header* fill-array
))))
834 (compiler-style-warn "The default initial element ~S is not a ~S."
835 default-initial-element
837 (let ((lambda-list `(length ,@(eliminate-keywords))))
838 `(lambda ,lambda-list
839 (declare (ignorable ,@lambda-list
))
840 ,(with-alloc-form))))))))
842 ;;; IMPORTANT: The order of these three MAKE-ARRAY forms matters: the least
843 ;;; specific must come first, otherwise suboptimal transforms will result for
846 (deftransform make-array
((dims &key initial-element initial-contents
848 adjustable fill-pointer
850 displaced-index-offset
)
853 (delay-ir1-transform node
:constraint
)
854 (when (and initial-contents initial-element
)
855 (compiler-warn "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS")
856 (give-up-ir1-transform))
857 (when (and displaced-index-offset
859 (compiler-warn "Can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO")
860 (give-up-ir1-transform))
861 (let ((fp-type (and fill-pointer
862 (lvar-type fill-pointer
)) ))
864 (csubtypep fp-type
(specifier-type '(or index
(eql t
)))))
865 (let* ((dims (and (constant-lvar-p dims
)
867 (length (cond ((integerp dims
)
873 (compiler-warn "Only vectors can have fill pointers."))
874 ((and (csubtypep fp-type
(specifier-type 'index
))
875 (not (types-equal-or-intersect fp-type
876 (specifier-type `(integer 0 ,length
)))))
877 (compiler-warn "Invalid fill-pointer ~s for a vector of length ~s."
878 (type-specifier fp-type
)
880 (macrolet ((maybe-arg (arg)
881 `(and ,arg
`(,,(keywordicate arg
) ,',arg
))))
882 (let* ((eltype (cond ((not element-type
) t
)
883 ((not (constant-lvar-p element-type
))
884 (give-up-ir1-transform
885 "ELEMENT-TYPE is not constant."))
887 (lvar-value element-type
))))
888 (eltype-type (ir1-transform-specifier-type eltype
))
889 (saetp (if (unknown-type-p eltype-type
)
890 (give-up-ir1-transform
891 "ELEMENT-TYPE ~s is not a known type"
894 sb
!vm
:*specialized-array-element-type-properties
*
895 :key
#'sb
!vm
:saetp-ctype
897 (creation-form `(%make-array
900 (sb!vm
:saetp-typecode saetp
)
901 (give-up-ir1-transform))
902 ,(sb!vm
:saetp-n-bits-shift saetp
)
903 ,@(maybe-arg initial-contents
)
904 ,@(maybe-arg adjustable
)
905 ,@(maybe-arg fill-pointer
)
906 ,@(maybe-arg displaced-to
)
907 ,@(maybe-arg displaced-index-offset
))))
908 (cond ((or (not initial-element
)
909 (and (constant-lvar-p initial-element
)
910 (eql (lvar-value initial-element
)
911 (sb!vm
:saetp-initial-element-default saetp
))))
914 ;; error checking for target, disabled on the host because
915 ;; (CTYPE-OF #\Null) is not possible.
917 (when (constant-lvar-p initial-element
)
918 (let ((value (lvar-value initial-element
)))
920 ((not (ctypep value
(sb!vm
:saetp-ctype saetp
)))
921 ;; this case will cause an error at runtime, so we'd
922 ;; better WARN about it now.
923 (warn 'array-initial-element-mismatch
924 :format-control
"~@<~S is not a ~S (which is the ~
929 (type-specifier (sb!vm
:saetp-ctype saetp
))
930 'upgraded-array-element-type
932 ((not (ctypep value eltype-type
))
933 ;; this case will not cause an error at runtime, but
934 ;; it's still worth STYLE-WARNing about.
935 (compiler-style-warn "~S is not a ~S."
937 `(let ((array ,creation-form
))
938 (multiple-value-bind (vector)
939 (%data-vector-and-index array
0)
940 (fill vector
(the ,(sb!vm
:saetp-specifier saetp
) initial-element
)))
943 ;;; The list type restriction does not ensure that the result will be a
944 ;;; multi-dimensional array. But the lack of adjustable, fill-pointer,
945 ;;; and displaced-to keywords ensures that it will be simple.
946 (deftransform make-array
((dims &key
947 element-type initial-element initial-contents
948 adjustable fill-pointer
)
950 (:element-type
(constant-arg *))
952 (:initial-contents
*)
958 ;; If lvar-use of DIMS is a call to LIST, then it must mean that LIST
959 ;; was declared notinline - because if it weren't, then it would have been
960 ;; source-transformed into CONS - which gives us reason NOT to optimize
961 ;; this call to MAKE-ARRAY. So look for CONS instead of LIST,
962 ;; which means that LIST was *not* declared notinline.
963 (when (and (lvar-matches dims
:fun-names
'(cons) :arg-count
2)
964 (let ((cdr (second (combination-args (lvar-uses dims
)))))
965 (and (constant-lvar-p cdr
) (null (lvar-value cdr
)))))
966 (let* ((args (splice-fun-args dims
:any
2)) ; the args to CONS
969 (setf (combination-args call
) (delete dummy
(combination-args call
)))
970 (return-from make-array
971 (transform-make-array-vector (car args
)
976 :adjustable adjustable
977 :fill-pointer fill-pointer
))))
978 (unless (constant-lvar-p dims
)
979 (give-up-ir1-transform
980 "The dimension list is not constant; cannot open code array creation."))
981 (let ((dims (lvar-value dims
))
982 (element-type-ctype (and (constant-lvar-p element-type
)
983 (ir1-transform-specifier-type
984 (lvar-value element-type
)))))
985 (when (contains-unknown-type-p element-type-ctype
)
986 (give-up-ir1-transform))
987 (unless (every (lambda (x) (typep x
'(integer 0))) dims
)
988 (give-up-ir1-transform
989 "The dimension list contains something other than an integer: ~S"
991 (cond ((singleton-p dims
)
992 (transform-make-array-vector (car dims
) element-type
993 initial-element initial-contents call
994 :adjustable adjustable
995 :fill-pointer fill-pointer
))
998 (constant-lvar-p fill-pointer
)
999 (null (lvar-value fill-pointer
)))))
1000 (give-up-ir1-transform))
1002 (let* ((total-size (reduce #'* dims
))
1003 (rank (length dims
))
1004 (complex (cond ((not adjustable
) nil
)
1005 ((not (constant-lvar-p adjustable
))
1006 (give-up-ir1-transform))
1007 ((lvar-value adjustable
))))
1008 (spec `(,(if complex
1011 ,(cond ((null element-type
) t
)
1013 (sb!xc
:upgraded-array-element-type
1014 (lvar-value element-type
)))
1016 ,(make-list rank
:initial-element
'*))))
1017 `(let ((header (make-array-header ,(if complex
1018 sb
!vm
:complex-array-widetag
1019 sb
!vm
:simple-array-widetag
)
1021 (data (make-array ,total-size
1022 ,@(when element-type
1023 '(:element-type element-type
))
1024 ,@(when initial-element
1025 '(:initial-element initial-element
)))))
1026 ,@(when initial-contents
1027 ;; FIXME: This is could be open coded at least a bit too
1028 `((fill-data-vector data
',dims initial-contents
)))
1029 (setf (%array-fill-pointer header
) ,total-size
)
1030 (setf (%array-fill-pointer-p header
) nil
)
1031 (setf (%array-available-elements header
) ,total-size
)
1032 (setf (%array-data header
) data
)
1033 (setf (%array-displaced-p header
) nil
)
1034 (setf (%array-displaced-from header
) nil
)
1036 (mapcar (lambda (dim)
1037 `(setf (%array-dimension header
,(incf axis
))
1040 (truly-the ,spec header
))))))))
1042 (deftransform make-array
((dims &key element-type initial-element initial-contents
1043 adjustable fill-pointer
)
1045 (:element-type
(constant-arg *))
1046 (:initial-element
*)
1047 (:initial-contents
*)
1052 (transform-make-array-vector dims
1057 :adjustable adjustable
1058 :fill-pointer fill-pointer
))
1061 (deftransform adjust-array
((array dims
&key displaced-to displaced-index-offset
)
1063 (:displaced-to array
)
1064 (:displaced-index-offset
*)))
1065 (unless displaced-to
1066 (give-up-ir1-transform))
1068 (when (invalid-array-p array
)
1069 (invalid-array-error array
))
1070 (unless (= 1 (array-rank array
))
1071 (error "The number of dimensions is not equal to the rank of the array"))
1072 (unless (eql (array-element-type array
) (array-element-type displaced-to
))
1073 (error "Can't displace an array of type ~S to another of type ~S"
1074 (array-element-type array
) (array-element-type displaced-to
)))
1075 (let ((displacement (or displaced-index-offset
0)))
1076 (when (< (array-total-size displaced-to
) (+ displacement dims
))
1077 (error "The :DISPLACED-TO array is too small"))
1078 (if (adjustable-array-p array
)
1079 (let ((nfp (when (array-has-fill-pointer-p array
)
1080 (when (> (%array-fill-pointer array
) dims
)
1081 (error "Cannot ADJUST-ARRAY an array to a size smaller than its fill pointer"))
1082 (%array-fill-pointer array
))))
1083 (set-array-header array displaced-to dims nfp
1084 displacement dims t nil
))
1085 (make-array dims
:element-type
(array-element-type array
)
1086 :displaced-to displaced-to
1087 ,@(and displaced-index-offset
1088 '(:displaced-index-offset displacement
)))))))
1090 ;;;; miscellaneous properties of arrays
1092 ;;; Transforms for various array properties. If the property is know
1093 ;;; at compile time because of a type spec, use that constant value.
1095 ;;; Most of this logic may end up belonging in code/late-type.lisp;
1096 ;;; however, here we also need the -OR-GIVE-UP for the transforms, and
1097 ;;; maybe this is just too sloppy for actual type logic. -- CSR,
1099 (defun array-type-dimensions-or-give-up (type)
1100 (labels ((maybe-array-type-dimensions (type)
1103 (array-type-dimensions type
))
1105 (let* ((types (loop for type in
(union-type-types type
)
1106 for dimensions
= (maybe-array-type-dimensions type
)
1107 when
(eq dimensions
'*)
1109 (return-from maybe-array-type-dimensions
'*)
1112 (result (car types
))
1113 (length (length result
))
1115 (dolist (other (cdr types
))
1116 (when (/= length
(length other
))
1117 (give-up-ir1-transform
1118 "~@<dimensions of arrays in union type ~S do not match~:@>"
1119 (type-specifier type
)))
1120 (unless (equal result other
)
1121 (setf complete-match nil
)))
1124 (make-list length
:initial-element
'*))))
1126 (let* ((types (remove nil
(mapcar #'maybe-array-type-dimensions
1127 (intersection-type-types type
))))
1128 (result (car types
)))
1129 (dolist (other (cdr types
) result
)
1130 (unless (equal result other
)
1131 (abort-ir1-transform
1132 "~@<dimensions of arrays in intersection type ~S do not match~:@>"
1133 (type-specifier type
)))))))))
1134 (or (maybe-array-type-dimensions type
)
1135 (give-up-ir1-transform
1136 "~@<don't know how to extract array dimensions from type ~S~:@>"
1137 (type-specifier type
)))))
1139 (defun conservative-array-type-complexp (type)
1141 (array-type (array-type-complexp type
))
1143 (let ((types (union-type-types type
)))
1144 (aver (> (length types
) 1))
1145 (let ((result (conservative-array-type-complexp (car types
))))
1146 (dolist (type (cdr types
) result
)
1147 (unless (eq (conservative-array-type-complexp type
) result
)
1148 (return-from conservative-array-type-complexp
:maybe
))))))
1149 ;; FIXME: intersection type
1152 ;; Let type derivation handle constant cases. We only do easy strength
1154 (deftransform array-rank
((array) (array) * :node node
)
1155 (let ((array-type (lvar-type array
)))
1156 (cond ((eq t
(and (array-type-p array-type
)
1157 (array-type-complexp array-type
)))
1158 '(%array-rank array
))
1160 (delay-ir1-transform node
:constraint
)
1161 `(if (array-header-p array
)
1165 (defun derive-array-rank (ctype)
1166 (let ((array (specifier-type 'array
)))
1168 (cond ((not (types-equal-or-intersect x array
))
1169 '()) ; Definitely not an array!
1171 (let ((dims (array-type-dimensions x
)))
1174 (list (length dims
)))))
1177 ;; Might as well catch some easy negation cases.
1180 (let ((dims (array-type-dimensions x
)))
1181 (cond ((eql dims
'*)
1183 ((every (lambda (dim)
1186 (list (length dims
)))
1190 (declare (dynamic-extent #'over
#'under
))
1191 (multiple-value-bind (not-p ranks
)
1192 (list-abstract-type-function ctype
#'over
:under
#'under
)
1193 (cond ((eql ranks
'*)
1197 (specifier-type `(not (member ,@ranks
))))
1199 (specifier-type `(member ,@ranks
))))))))
1201 (defoptimizer (array-rank derive-type
) ((array))
1202 (derive-array-rank (lvar-type array
)))
1204 (defoptimizer (%array-rank derive-type
) ((array))
1205 (derive-array-rank (lvar-type array
)))
1207 ;;; If we know the dimensions at compile time, just use it. Otherwise,
1208 ;;; if we can tell that the axis is in bounds, convert to
1209 ;;; %ARRAY-DIMENSION (which just indirects the array header) or length
1210 ;;; (if it's simple and a vector).
1211 (deftransform array-dimension
((array axis
)
1213 (unless (constant-lvar-p axis
)
1214 (give-up-ir1-transform "The axis is not constant."))
1215 ;; Dimensions may change thanks to ADJUST-ARRAY, so we need the
1216 ;; conservative type.
1217 (let ((array-type (lvar-conservative-type array
))
1218 (axis (lvar-value axis
)))
1219 (let ((dims (array-type-dimensions-or-give-up array-type
)))
1220 (unless (listp dims
)
1221 (give-up-ir1-transform
1222 "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime."))
1223 (unless (> (length dims
) axis
)
1224 (abort-ir1-transform "The array has dimensions ~S, ~W is too large."
1227 (let ((dim (nth axis dims
)))
1228 (cond ((integerp dim
)
1230 ((= (length dims
) 1)
1231 (ecase (conservative-array-type-complexp array-type
)
1233 '(%array-dimension array
0))
1235 '(vector-length array
))
1237 `(if (array-header-p array
)
1238 (%array-dimension array axis
)
1239 (vector-length array
)))))
1241 '(%array-dimension array axis
)))))))
1243 ;;; If the length has been declared and it's simple, just return it.
1244 (deftransform length
((vector)
1245 ((simple-array * (*))))
1246 (let ((type (lvar-type vector
)))
1247 (let ((dims (array-type-dimensions-or-give-up type
)))
1248 (unless (and (listp dims
) (integerp (car dims
)))
1249 (give-up-ir1-transform
1250 "Vector length is unknown, must call LENGTH at runtime."))
1253 ;;; All vectors can get their length by using VECTOR-LENGTH. If it's
1254 ;;; simple, it will extract the length slot from the vector. It it's
1255 ;;; complex, it will extract the fill pointer slot from the array
1257 (deftransform length
((vector) (vector))
1258 '(vector-length vector
))
1260 ;;; If a simple array with known dimensions, then VECTOR-LENGTH is a
1261 ;;; compile-time constant.
1262 (deftransform vector-length
((vector))
1263 (let ((vtype (lvar-type vector
)))
1264 (let ((dim (first (array-type-dimensions-or-give-up vtype
))))
1266 (give-up-ir1-transform))
1267 (when (conservative-array-type-complexp vtype
)
1268 (give-up-ir1-transform))
1271 ;;; Again, if we can tell the results from the type, just use it.
1272 ;;; Otherwise, if we know the rank, convert into a computation based
1273 ;;; on array-dimension or %array-available-elements
1274 (deftransform array-total-size
((array) (array))
1275 (let* ((array-type (lvar-type array
))
1276 (dims (array-type-dimensions-or-give-up array-type
)))
1277 (unless (listp dims
)
1278 (give-up-ir1-transform "can't tell the rank at compile time"))
1279 (cond ((not (memq '* dims
))
1282 ;; A vector, can't use LENGTH since this ignores the fill-pointer
1283 `(truly-the index
(array-dimension array
0)))
1285 `(%array-available-elements array
)))))
1287 ;;; Only complex vectors have fill pointers.
1288 (deftransform array-has-fill-pointer-p
((array))
1289 (let ((array-type (lvar-type array
)))
1290 (let ((dims (array-type-dimensions-or-give-up array-type
)))
1291 (if (and (listp dims
) (not (= (length dims
) 1)))
1293 (ecase (conservative-array-type-complexp array-type
)
1299 (give-up-ir1-transform
1300 "The array type is ambiguous; must call ~
1301 ARRAY-HAS-FILL-POINTER-P at runtime.")))))))
1303 (deftransform check-bound
((array dimension index
) * * :node node
)
1304 ;; This is simply to avoid multiple evaluation of INDEX by the
1305 ;; translator, it's easier to wrap it in a lambda from DEFTRANSFORM
1306 `(bound-cast array
,(if (constant-lvar-p dimension
)
1307 (lvar-value dimension
)
1311 ;;;; WITH-ARRAY-DATA
1313 ;;; This checks to see whether the array is simple and the start and
1314 ;;; end are in bounds. If so, it proceeds with those values.
1315 ;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that %WITH-ARRAY-DATA
1316 ;;; may be further optimized.
1318 ;;; Given any ARRAY, bind DATA-VAR to the array's data vector and
1319 ;;; START-VAR and END-VAR to the start and end of the designated
1320 ;;; portion of the data vector. SVALUE and EVALUE are any start and
1321 ;;; end specified to the original operation, and are factored into the
1322 ;;; bindings of START-VAR and END-VAR. OFFSET-VAR is the cumulative
1323 ;;; offset of all displacements encountered, and does not include
1326 ;;; When FORCE-INLINE is set, the underlying %WITH-ARRAY-DATA form is
1327 ;;; forced to be inline, overriding the ordinary judgment of the
1328 ;;; %WITH-ARRAY-DATA DEFTRANSFORMs. Ordinarily the DEFTRANSFORMs are
1329 ;;; fairly picky about their arguments, figuring that if you haven't
1330 ;;; bothered to get all your ducks in a row, you probably don't care
1331 ;;; that much about speed anyway! But in some cases it makes sense to
1332 ;;; do type testing inside %WITH-ARRAY-DATA instead of outside, and
1333 ;;; the DEFTRANSFORM can't tell that that's going on, so it can make
1334 ;;; sense to use FORCE-INLINE option in that case.
1335 (sb!xc
:defmacro with-array-data
(((data-var array
&key offset-var
)
1336 (start-var &optional
(svalue 0))
1337 (end-var &optional
(evalue nil
))
1338 &key force-inline check-fill-pointer
1342 (once-only ((n-array array
)
1343 (n-svalue `(the index
,svalue
))
1344 (n-evalue `(the (or index null
) ,evalue
)))
1345 (let ((check-bounds (policy env
(plusp insert-array-bounds-checks
))))
1346 `(multiple-value-bind (,data-var
1349 ,@ (when offset-var
`(,offset-var
)))
1350 (cond ,@(and (not array-header-p
)
1351 `(((not (array-header-p ,n-array
))
1352 (let ((,n-array
,n-array
))
1353 (declare (type vector
,n-array
))
1354 ,(once-only ((n-len `(length ,n-array
))
1355 (n-end `(or ,n-evalue
,n-len
)))
1357 `(if (<= 0 ,n-svalue
,n-end
,n-len
)
1358 (values (truly-the simple-array
,n-array
)
1360 ,(if check-fill-pointer
1361 `(sequence-bounding-indices-bad-error ,n-array
,n-svalue
,n-evalue
)
1362 `(array-bounding-indices-bad-error ,n-array
,n-svalue
,n-evalue
)))
1363 `(values (truly-the simple-array
,n-array
)
1364 ,n-svalue
,n-end
0)))))))
1366 ,(cond (force-inline
1367 `(%with-array-data-macro
,n-array
,n-svalue
,n-evalue
1368 :check-bounds
,check-bounds
1369 :check-fill-pointer
,check-fill-pointer
1372 `(%with-array-data
/fp
,n-array
,n-svalue
,n-evalue
))
1374 `(%with-array-data
,n-array
,n-svalue
,n-evalue
)))))
1377 ;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in
1378 ;;; DEFTRANSFORMs and DEFUNs.
1379 (sb!xc
:defmacro %with-array-data-macro
1380 (array start end
&key
(element-type '*) check-bounds check-fill-pointer
1382 (with-unique-names (size defaulted-end data cumulative-offset
)
1383 `(let* ((,size
,(cond (check-fill-pointer
1384 `(length (the vector
,array
)))
1386 `(%array-available-elements
,array
))
1388 `(array-total-size ,array
))))
1389 (,defaulted-end
(or ,end
,size
)))
1390 ,@ (when check-bounds
1391 `((unless (<= ,start
,defaulted-end
,size
)
1392 ,(if check-fill-pointer
1393 `(sequence-bounding-indices-bad-error ,array
,start
,end
)
1394 `(array-bounding-indices-bad-error ,array
,start
,end
)))))
1395 (do ((,data
,(if array-header-p
1396 `(%array-data
,array
)
1398 (%array-data
,data
))
1399 (,cumulative-offset
,(if array-header-p
1400 `(%array-displacement
,array
)
1403 (+ ,cumulative-offset
1404 (%array-displacement
,data
)))))
1405 ((not (array-header-p ,data
))
1406 (values (truly-the (simple-array ,element-type
1) ,data
)
1407 (truly-the index
(+ ,cumulative-offset
,start
))
1408 (truly-the index
(+ ,cumulative-offset
,defaulted-end
))
1409 ,cumulative-offset
))))))
1411 (defun transform-%with-array-data
/mumble
(array node check-fill-pointer
)
1412 (let ((element-type (upgraded-element-type-specifier-or-give-up array
))
1413 (type (lvar-type array
))
1414 (check-bounds (policy node
(plusp insert-array-bounds-checks
))))
1415 (if (and (array-type-p type
)
1416 (not (array-type-complexp type
))
1417 (listp (array-type-dimensions type
))
1418 (not (null (cdr (array-type-dimensions type
)))))
1419 ;; If it's a simple multidimensional array, then just return
1420 ;; its data vector directly rather than going through
1421 ;; %WITH-ARRAY-DATA-MACRO. SBCL doesn't generally generate
1422 ;; code that would use this currently, but we have encouraged
1423 ;; users to use WITH-ARRAY-DATA and we may use it ourselves at
1424 ;; some point in the future for optimized libraries or
1427 `(let* ((data (truly-the (simple-array ,element-type
(*))
1428 (%array-data array
)))
1430 (real-end (or end len
)))
1431 (unless (<= 0 start data-end lend
)
1432 (sequence-bounding-indices-bad-error array start end
))
1433 (values data
0 real-end
0))
1434 `(let ((data (truly-the (simple-array ,element-type
(*))
1435 (%array-data array
))))
1436 (values data
0 (or end
(length data
)) 0)))
1437 `(%with-array-data-macro array start end
1438 :check-fill-pointer
,check-fill-pointer
1439 :check-bounds
,check-bounds
1440 :element-type
,element-type
))))
1442 ;; It might very well be reasonable to allow general ARRAY here, I
1443 ;; just haven't tried to understand the performance issues involved.
1444 ;; -- WHN, and also CSR 2002-05-26
1445 (deftransform %with-array-data
((array start end
)
1446 ((or vector simple-array
) index
(or index null
) t
)
1449 :policy
(> speed space
))
1450 "inline non-SIMPLE-vector-handling logic"
1451 (transform-%with-array-data
/mumble array node nil
))
1452 (deftransform %with-array-data
/fp
((array start end
)
1453 ((or vector simple-array
) index
(or index null
) t
)
1456 :policy
(> speed space
))
1457 "inline non-SIMPLE-vector-handling logic"
1458 (transform-%with-array-data
/mumble array node t
))
1460 ;;;; array accessors
1462 ;;; We convert all typed array accessors into AREF and (SETF AREF) with type
1463 ;;; assertions on the array.
1464 (macrolet ((define-bit-frob (reffer simplep
)
1466 (define-source-transform ,reffer
(a &rest i
)
1467 `(aref (the (,',(if simplep
'simple-array
'array
)
1469 ,(mapcar (constantly '*) i
))
1471 (define-source-transform (setf ,reffer
) (value a
&rest i
)
1472 `(setf (aref (the (,',(if simplep
'simple-array
'array
)
1474 ,(mapcar (constantly '*) i
))
1477 (define-bit-frob sbit t
)
1478 (define-bit-frob bit nil
))
1480 (macrolet ((define-frob (reffer setter type
)
1482 (define-source-transform ,reffer
(a i
)
1483 `(aref (the ,',type
,a
) ,i
))
1484 (define-source-transform ,setter
(a i v
)
1485 `(setf (aref (the ,',type
,a
) ,i
) ,v
)))))
1486 (define-frob schar %scharset simple-string
)
1487 (define-frob char %charset string
))
1489 ;;; We transform SVREF and %SVSET directly into DATA-VECTOR-REF/SET: this is
1490 ;;; around 100 times faster than going through the general-purpose AREF
1491 ;;; transform which ends up doing a lot of work -- and introducing many
1492 ;;; intermediate lambdas, each meaning a new trip through the compiler -- to
1493 ;;; get the same result.
1495 ;;; FIXME: [S]CHAR, and [S]BIT above would almost certainly benefit from a similar
1497 (define-source-transform svref
(vector index
)
1498 (let ((elt-type (or (when (symbolp vector
)
1499 (let ((var (lexenv-find vector vars
)))
1500 (when (lambda-var-p var
)
1502 (array-type-declared-element-type (lambda-var-type var
))))))
1504 (with-unique-names (n-vector)
1505 `(let ((,n-vector
,vector
))
1506 (the ,elt-type
(data-vector-ref
1507 (the simple-vector
,n-vector
)
1508 (check-bound ,n-vector
(length ,n-vector
) ,index
)))))))
1510 (define-source-transform %svset
(vector index value
)
1511 (let ((elt-type (or (when (symbolp vector
)
1512 (let ((var (lexenv-find vector vars
)))
1513 (when (lambda-var-p var
)
1515 (array-type-declared-element-type (lambda-var-type var
))))))
1517 (with-unique-names (n-vector)
1518 `(let ((,n-vector
,vector
))
1519 (truly-the ,elt-type
(data-vector-set
1520 (the simple-vector
,n-vector
)
1521 (check-bound ,n-vector
(length ,n-vector
) ,index
)
1522 (the ,elt-type
,value
)))))))
1524 (macrolet (;; This is a handy macro for computing the row-major index
1525 ;; given a set of indices. We wrap each index with a call
1526 ;; to CHECK-BOUND to ensure that everything works out
1527 ;; correctly. We can wrap all the interior arithmetic with
1528 ;; TRULY-THE INDEX because we know the resultant
1529 ;; row-major index must be an index.
1530 (with-row-major-index ((array indices index
&optional new-value
)
1532 `(let (n-indices dims
)
1533 (dotimes (i (length ,indices
))
1534 (push (make-symbol (format nil
"INDEX-~D" i
)) n-indices
)
1535 (push (make-symbol (format nil
"DIM-~D" i
)) dims
))
1536 (setf n-indices
(nreverse n-indices
))
1537 (setf dims
(nreverse dims
))
1538 `(lambda (,@',(when new-value
(list new-value
))
1539 ,',array
,@n-indices
)
1540 (declare (ignorable ,',array
))
1541 (let* (,@(let ((,index -
1))
1542 (mapcar (lambda (name)
1543 `(,name
(array-dimension
1550 (do* ((dims dims
(cdr dims
))
1551 (indices n-indices
(cdr indices
))
1552 (last-dim nil
(car dims
))
1553 (form `(check-bound ,',array
1565 ((null (cdr dims
)) form
)))))
1568 ;; Just return the index after computing it.
1569 (deftransform array-row-major-index
((array &rest indices
))
1570 (with-row-major-index (array indices index
)
1573 ;; Convert AREF and (SETF AREF) into a HAIRY-DATA-VECTOR-REF (or
1574 ;; HAIRY-DATA-VECTOR-SET) with the set of indices replaced with the an
1575 ;; expression for the row major index.
1576 (deftransform aref
((array &rest indices
))
1577 (with-row-major-index (array indices index
)
1578 (hairy-data-vector-ref array index
)))
1580 (deftransform (setf aref
) ((new-value array
&rest subscripts
))
1581 (with-row-major-index (array subscripts index new-value
)
1582 (hairy-data-vector-set array index new-value
))))
1584 ;; For AREF of vectors we do the bounds checking in the callee. This
1585 ;; lets us do a significantly more efficient check for simple-arrays
1586 ;; without bloating the code. If we already know the type of the array
1587 ;; with sufficient precision, skip directly to DATA-VECTOR-REF.
1588 (deftransform aref
((array index
) (t t
) * :node node
)
1589 (let* ((type (lvar-type array
))
1590 (element-ctype (array-type-upgraded-element-type type
)))
1592 ((eq element-ctype
*empty-type
*)
1593 `(data-nil-vector-ref array index
))
1594 ((and (array-type-p type
)
1595 (null (array-type-complexp type
))
1596 (neq element-ctype
*wild-type
*)
1597 (eql (length (array-type-dimensions type
)) 1))
1598 (let* ((declared-element-ctype (array-type-declared-element-type type
))
1600 `(data-vector-ref array
1601 (check-bound array
(array-dimension array
0) index
))))
1602 (if (type= declared-element-ctype element-ctype
)
1604 `(the ,(type-specifier declared-element-ctype
) ,bare-form
))))
1605 ((policy node
(zerop insert-array-bounds-checks
))
1606 `(hairy-data-vector-ref array index
))
1607 (t `(hairy-data-vector-ref/check-bounds array index
)))))
1609 (deftransform (setf aref
) ((new-value array index
) (t t t
) * :node node
)
1610 (if (policy node
(zerop insert-array-bounds-checks
))
1611 `(hairy-data-vector-set array index new-value
)
1612 `(hairy-data-vector-set/check-bounds array index new-value
)))
1614 ;;; But if we find out later that there's some useful type information
1615 ;;; available, switch back to the normal one to give other transforms
1617 (macrolet ((define (name transform-to extra extra-type
)
1618 (declare (ignore extra-type
))
1619 `(deftransform ,name
((array index
,@extra
))
1620 (let* ((type (lvar-type array
))
1621 (element-type (array-type-upgraded-element-type type
))
1622 (declared-type (type-specifier
1623 (array-type-declared-element-type type
))))
1624 ;; If an element type has been declared, we want to
1625 ;; use that information it for type checking (even
1626 ;; if the access can't be optimized due to the array
1627 ;; not being simple).
1628 (when (and (eq element-type
*wild-type
*)
1629 ;; This type logic corresponds to the special
1630 ;; case for strings in HAIRY-DATA-VECTOR-REF
1631 ;; (generic/vm-tran.lisp)
1632 (not (csubtypep type
(specifier-type 'simple-string
))))
1633 (when (or (not (array-type-p type
))
1634 ;; If it's a simple array, we might be able
1635 ;; to inline the access completely.
1636 (not (null (array-type-complexp type
))))
1637 (give-up-ir1-transform
1638 "Upgraded element type of array is not known at compile time.")))
1640 ``(truly-the ,declared-type
1641 (,',transform-to array
1643 (array-dimension array
0)
1645 (the ,declared-type
,@',extra
)))
1646 ``(the ,declared-type
1647 (,',transform-to array
1649 (array-dimension array
0)
1651 (define hairy-data-vector-ref
/check-bounds
1652 hairy-data-vector-ref nil nil
)
1653 (define hairy-data-vector-set
/check-bounds
1654 hairy-data-vector-set
(new-value) (*)))
1656 ;;; Just convert into a HAIRY-DATA-VECTOR-REF (or
1657 ;;; HAIRY-DATA-VECTOR-SET) after checking that the index is inside the
1658 ;;; array total size.
1659 (deftransform row-major-aref
((array index
))
1660 `(hairy-data-vector-ref array
1661 (check-bound array
(array-total-size array
) index
)))
1662 (deftransform %set-row-major-aref
((array index new-value
))
1663 `(hairy-data-vector-set array
1664 (check-bound array
(array-total-size array
) index
)
1667 ;;;; bit-vector array operation canonicalization
1669 ;;;; We convert all bit-vector operations to have the result array
1670 ;;;; specified. This allows any result allocation to be open-coded,
1671 ;;;; and eliminates the need for any VM-dependent transforms to handle
1674 (macrolet ((def (fun)
1676 (deftransform ,fun
((bit-array-1 bit-array-2
1677 &optional result-bit-array
)
1678 (bit-vector bit-vector
&optional null
) *
1679 :policy
(>= speed space
))
1680 `(,',fun bit-array-1 bit-array-2
1681 (make-array (array-dimension bit-array-1
0) :element-type
'bit
)))
1682 ;; If result is T, make it the first arg.
1683 (deftransform ,fun
((bit-array-1 bit-array-2 result-bit-array
)
1684 (bit-vector bit-vector
(eql t
)) *)
1685 `(,',fun bit-array-1 bit-array-2 bit-array-1
)))))
1697 ;;; Similar for BIT-NOT, but there is only one arg...
1698 (deftransform bit-not
((bit-array-1 &optional result-bit-array
)
1699 (bit-vector &optional null
) *
1700 :policy
(>= speed space
))
1701 '(bit-not bit-array-1
1702 (make-array (array-dimension bit-array-1
0) :element-type
'bit
)))
1703 (deftransform bit-not
((bit-array-1 result-bit-array
)
1704 (bit-vector (eql t
)))
1705 '(bit-not bit-array-1 bit-array-1
))
1707 ;;; Pick off some constant cases.
1708 (defoptimizer (array-header-p derive-type
) ((array))
1709 (let ((type (lvar-type array
)))
1710 (cond ((not (array-type-p type
))
1711 ;; FIXME: use analogue of ARRAY-TYPE-DIMENSIONS-OR-GIVE-UP
1714 (let ((dims (array-type-dimensions type
)))
1715 (cond ((csubtypep type
(specifier-type '(simple-array * (*))))
1717 (specifier-type 'null
))
1718 ((and (listp dims
) (/= (length dims
) 1))
1719 ;; multi-dimensional array, will have a header
1720 (specifier-type '(eql t
)))
1721 ((eql (array-type-complexp type
) t
)
1722 (specifier-type '(eql t
)))