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.
17 ;;;; Derive-Type Optimizers
19 ;;; Array operations that use a specific number of indices implicitly assert
20 ;;; that the array is of that rank.
21 (defun assert-array-rank (array rank)
22 (assert-continuation-type
24 (specifier-type `(array * ,(make-list rank :initial-element '*)))))
26 ;;; Array access functions return an object from the array, hence its
27 ;;; type will be asserted to be array element type.
28 (defun extract-element-type (array)
29 (let ((type (continuation-type array)))
30 (if (array-type-p type)
31 (array-type-element-type type)
34 ;;; Array access functions return an object from the array, hence its
35 ;;; type is going to be the array upgraded element type.
36 (defun extract-upgraded-element-type (array)
37 (let ((type (continuation-type array)))
38 (if (array-type-p type)
39 (array-type-specialized-element-type type)
42 ;;; The ``new-value'' for array setters must fit in the array, and the
43 ;;; return type is going to be the same as the new-value for SETF
45 (defun assert-new-value-type (new-value array)
46 (let ((type (continuation-type array)))
47 (when (array-type-p type)
48 (assert-continuation-type new-value (array-type-element-type type))))
49 (continuation-type new-value))
51 ;;; Return true if Arg is NIL, or is a constant-continuation whose value is
52 ;;; NIL, false otherwise.
53 (defun unsupplied-or-nil (arg)
54 (declare (type (or continuation null) arg))
56 (and (constant-continuation-p arg)
57 (not (continuation-value arg)))))
59 (defoptimizer (array-in-bounds-p derive-type) ((array &rest indices))
60 (assert-array-rank array (length indices))
63 (defoptimizer (aref derive-type) ((array &rest indices) node)
64 (assert-array-rank array (length indices))
65 ;; If the node continuation has a single use then assert its type.
66 (let ((cont (node-cont node)))
67 (when (= (length (find-uses cont)) 1)
68 (assert-continuation-type cont (extract-element-type array))))
69 (extract-upgraded-element-type array))
71 (defoptimizer (%aset derive-type) ((array &rest stuff))
72 (assert-array-rank array (1- (length stuff)))
73 (assert-new-value-type (car (last stuff)) array))
75 (defoptimizer (hairy-data-vector-ref derive-type) ((array index))
76 (extract-upgraded-element-type array))
77 (defoptimizer (data-vector-ref derive-type) ((array index))
78 (extract-upgraded-element-type array))
80 (defoptimizer (data-vector-set derive-type) ((array index new-value))
81 (assert-new-value-type new-value array))
82 (defoptimizer (hairy-data-vector-set derive-type) ((array index new-value))
83 (assert-new-value-type new-value array))
85 ;;; Figure out the type of the data vector if we know the argument element
87 (defoptimizer (%with-array-data derive-type) ((array start end))
88 (let ((atype (continuation-type array)))
89 (when (array-type-p atype)
90 (values-specifier-type
91 `(values (simple-array ,(type-specifier
92 (array-type-element-type atype))
94 index index index)))))
96 (defoptimizer (array-row-major-index derive-type) ((array &rest indices))
97 (assert-array-rank array (length indices))
100 (defoptimizer (row-major-aref derive-type) ((array index))
101 (extract-upgraded-element-type array))
103 (defoptimizer (%set-row-major-aref derive-type) ((array index new-value))
104 (assert-new-value-type new-value array))
106 (defoptimizer (make-array derive-type)
107 ((dims &key initial-element element-type initial-contents
108 adjustable fill-pointer displaced-index-offset displaced-to))
109 (let ((simple (and (unsupplied-or-nil adjustable)
110 (unsupplied-or-nil displaced-to)
111 (unsupplied-or-nil fill-pointer))))
113 `(,(if simple 'simple-array 'array)
114 ,(cond ((not element-type) 't)
115 ((constant-continuation-p element-type)
116 (continuation-value element-type))
121 ((constant-continuation-p dims)
122 (let ((val (continuation-value dims)))
123 (if (listp val) val (list val))))
124 ((csubtypep (continuation-type dims)
125 (specifier-type 'integer))
132 ;;; Convert VECTOR into a MAKE-ARRAY followed by SETFs of all the
134 (def-source-transform vector (&rest elements)
137 (let ((len (length elements))
139 (once-only ((n-vec `(make-array ,len)))
141 ,@(mapcar #'(lambda (el)
142 (once-only ((n-val el))
143 `(locally (declare (optimize (safety 0)))
144 (setf (svref ,n-vec ,(incf n))
149 ;;; Just convert it into a MAKE-ARRAY.
150 (def-source-transform make-string (length &key
151 (element-type ''base-char)
152 (initial-element default-init-char))
155 `(make-array (the index ,length)
156 :element-type ,element-type
157 :initial-element ,initial-element)))
159 (defparameter *array-info*
160 #((base-char #.default-init-char 8 sb!vm:simple-string-type)
161 (single-float 0.0s0 32 sb!vm:simple-array-single-float-type)
162 (double-float 0.0d0 64 sb!vm:simple-array-double-float-type)
163 #!+long-float (long-float 0.0l0 #!+x86 96 #!+sparc 128
164 sb!vm:simple-array-long-float-type)
165 (bit 0 1 sb!vm:simple-bit-vector-type)
166 ((unsigned-byte 2) 0 2 sb!vm:simple-array-unsigned-byte-2-type)
167 ((unsigned-byte 4) 0 4 sb!vm:simple-array-unsigned-byte-4-type)
168 ((unsigned-byte 8) 0 8 sb!vm:simple-array-unsigned-byte-8-type)
169 ((unsigned-byte 16) 0 16 sb!vm:simple-array-unsigned-byte-16-type)
170 ((unsigned-byte 32) 0 32 sb!vm:simple-array-unsigned-byte-32-type)
171 ((signed-byte 8) 0 8 sb!vm:simple-array-signed-byte-8-type)
172 ((signed-byte 16) 0 16 sb!vm:simple-array-signed-byte-16-type)
173 ((signed-byte 30) 0 32 sb!vm:simple-array-signed-byte-30-type)
174 ((signed-byte 32) 0 32 sb!vm:simple-array-signed-byte-32-type)
175 ((complex single-float) #C(0.0s0 0.0s0) 64
176 sb!vm:simple-array-complex-single-float-type)
177 ((complex double-float) #C(0.0d0 0.0d0) 128
178 sb!vm:simple-array-complex-double-float-type)
180 ((complex long-float) #C(0.0l0 0.0l0) #!+x86 192 #!+sparc 256
181 sb!vm:simple-array-complex-long-float-type)
182 (t 0 32 sb!vm:simple-vector-type)))
184 ;;; The integer type restriction on the length ensures that it will be
185 ;;; a vector. The lack of adjustable, fill-pointer, and displaced-to
186 ;;; keywords ensures that it will be simple.
187 (deftransform make-array ((length &key initial-element element-type)
189 (let* ((eltype (cond ((not element-type) t)
190 ((not (constant-continuation-p element-type))
191 (give-up-ir1-transform
192 "ELEMENT-TYPE is not constant."))
194 (continuation-value element-type))))
195 (len (if (constant-continuation-p length)
196 (continuation-value length)
198 (spec `(simple-array ,eltype (,len)))
199 (eltype-type (specifier-type eltype)))
200 (multiple-value-bind (default-initial-element element-size typecode)
201 (dovector (info *array-info*
202 (give-up-ir1-transform
203 "cannot open-code creation of ~S" spec))
204 (when (csubtypep eltype-type (specifier-type (car info)))
205 (return (values-list (cdr info)))))
207 (if (>= element-size sb!vm:word-bits)
208 `(* length ,(/ element-size sb!vm:word-bits))
209 (let ((elements-per-word (/ 32 element-size)))
211 ,(if (eq 'sb!vm:simple-string-type typecode)
212 ;; (Simple strings are stored with an
213 ;; extra trailing null for convenience
214 ;; in calling out to C.)
216 (1- elements-per-word)))
217 ,elements-per-word))))
220 (allocate-vector ,typecode length ,nwords-form))))
222 (cond ((and default-initial-element
223 (or (null initial-element)
224 (and (constant-continuation-p initial-element)
225 (eql (continuation-value initial-element)
226 default-initial-element))))
227 (unless (csubtypep (ctype-of default-initial-element)
229 ;; This situation arises e.g. in
230 ;; (MAKE-ARRAY 4 :ELEMENT-TYPE '(INTEGER 1 5))
231 ;; ANSI's definition of MAKE-ARRAY says "If
232 ;; INITIAL-ELEMENT is not supplied, the consequences
233 ;; of later reading an uninitialized element of
234 ;; new-array are undefined," so this could be legal
235 ;; code as long as the user plans to write before he
236 ;; reads, and if he doesn't we're free to do
237 ;; anything we like. But in case the user doesn't
238 ;; know to write before he reads, we'll signal a
239 ;; STYLE-WARNING in case he didn't realize this.
241 ;; FIXME: should be STYLE-WARNING, not note
242 (compiler-note "The default initial element ~S is not a ~S."
243 default-initial-element
247 `(truly-the ,spec (fill ,constructor initial-element))))
248 '((declare (type index length))))))))
250 ;;; The list type restriction does not ensure that the result will be a
251 ;;; multi-dimensional array. But the lack of adjustable, fill-pointer,
252 ;;; and displaced-to keywords ensures that it will be simple.
253 (deftransform make-array ((dims &key initial-element element-type)
255 (unless (or (null element-type) (constant-continuation-p element-type))
256 (give-up-ir1-transform
257 "The element-type is not constant; cannot open code array creation."))
258 (unless (constant-continuation-p dims)
259 (give-up-ir1-transform
260 "The dimension list is not constant; cannot open code array creation."))
261 (let ((dims (continuation-value dims)))
262 (unless (every #'integerp dims)
263 (give-up-ir1-transform
264 "The dimension list contains something other than an integer: ~S"
266 (if (= (length dims) 1)
267 `(make-array ',(car dims)
268 ,@(when initial-element
269 '(:initial-element initial-element))
271 '(:element-type element-type)))
272 (let* ((total-size (reduce #'* dims))
275 ,(cond ((null element-type) t)
276 ((constant-continuation-p element-type)
277 (continuation-value element-type))
279 ,(make-list rank :initial-element '*))))
280 `(let ((header (make-array-header sb!vm:simple-array-type ,rank)))
281 (setf (%array-fill-pointer header) ,total-size)
282 (setf (%array-fill-pointer-p header) nil)
283 (setf (%array-available-elements header) ,total-size)
284 (setf (%array-data-vector header)
285 (make-array ,total-size
287 '(:element-type element-type))
288 ,@(when initial-element
289 '(:initial-element initial-element))))
290 (setf (%array-displaced-p header) nil)
292 (mapcar #'(lambda (dim)
293 `(setf (%array-dimension header ,(incf axis))
296 (truly-the ,spec header))))))
298 ;;;; miscellaneous properties of arrays
300 ;;; Transforms for various array properties. If the property is know
301 ;;; at compile time because of a type spec, use that constant value.
303 ;;; If we can tell the rank from the type info, use it instead.
304 (deftransform array-rank ((array))
305 (let ((array-type (continuation-type array)))
306 (unless (array-type-p array-type)
307 (give-up-ir1-transform))
308 (let ((dims (array-type-dimensions array-type)))
309 (if (not (listp dims))
310 (give-up-ir1-transform
311 "The array rank is not known at compile time: ~S"
315 ;;; If we know the dimensions at compile time, just use it. Otherwise,
316 ;;; if we can tell that the axis is in bounds, convert to
317 ;;; %ARRAY-DIMENSION (which just indirects the array header) or length
318 ;;; (if it's simple and a vector).
319 (deftransform array-dimension ((array axis)
321 (unless (constant-continuation-p axis)
322 (give-up-ir1-transform "The axis is not constant."))
323 (let ((array-type (continuation-type array))
324 (axis (continuation-value axis)))
325 (unless (array-type-p array-type)
326 (give-up-ir1-transform))
327 (let ((dims (array-type-dimensions array-type)))
329 (give-up-ir1-transform
330 "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime."))
331 (unless (> (length dims) axis)
332 (abort-ir1-transform "The array has dimensions ~S, ~D is too large."
335 (let ((dim (nth axis dims)))
336 (cond ((integerp dim)
339 (ecase (array-type-complexp array-type)
341 '(%array-dimension array 0))
345 (give-up-ir1-transform
346 "can't tell whether array is simple"))))
348 '(%array-dimension array axis)))))))
350 ;;; If the length has been declared and it's simple, just return it.
351 (deftransform length ((vector)
352 ((simple-array * (*))))
353 (let ((type (continuation-type vector)))
354 (unless (array-type-p type)
355 (give-up-ir1-transform))
356 (let ((dims (array-type-dimensions type)))
357 (unless (and (listp dims) (integerp (car dims)))
358 (give-up-ir1-transform
359 "Vector length is unknown, must call LENGTH at runtime."))
362 ;;; All vectors can get their length by using VECTOR-LENGTH. If it's
363 ;;; simple, it will extract the length slot from the vector. It it's
364 ;;; complex, it will extract the fill pointer slot from the array
366 (deftransform length ((vector) (vector))
367 '(vector-length vector))
369 ;;; If a simple array with known dimensions, then VECTOR-LENGTH is a
370 ;;; compile-time constant.
371 (deftransform vector-length ((vector) ((simple-array * (*))))
372 (let ((vtype (continuation-type vector)))
373 (if (array-type-p vtype)
374 (let ((dim (first (array-type-dimensions vtype))))
375 (when (eq dim '*) (give-up-ir1-transform))
377 (give-up-ir1-transform))))
379 ;;; Again, if we can tell the results from the type, just use it.
380 ;;; Otherwise, if we know the rank, convert into a computation based
381 ;;; on array-dimension. We can wrap a TRULY-THE INDEX around the
382 ;;; multiplications because we know that the total size must be an
384 (deftransform array-total-size ((array)
386 (let ((array-type (continuation-type array)))
387 (unless (array-type-p array-type)
388 (give-up-ir1-transform))
389 (let ((dims (array-type-dimensions array-type)))
391 (give-up-ir1-transform "can't tell the rank at compile time"))
393 (do ((form 1 `(truly-the index
394 (* (array-dimension array ,i) ,form)))
396 ((= i (length dims)) form))
397 (reduce #'* dims)))))
399 ;;; Only complex vectors have fill pointers.
400 (deftransform array-has-fill-pointer-p ((array))
401 (let ((array-type (continuation-type array)))
402 (unless (array-type-p array-type)
403 (give-up-ir1-transform))
404 (let ((dims (array-type-dimensions array-type)))
405 (if (and (listp dims) (not (= (length dims) 1)))
407 (ecase (array-type-complexp array-type)
413 (give-up-ir1-transform
414 "The array type is ambiguous; must call ~
415 array-has-fill-pointer-p at runtime.")))))))
417 ;;; Primitive used to verify indices into arrays. If we can tell at
418 ;;; compile-time or we are generating unsafe code, don't bother with
420 (deftransform %check-bound ((array dimension index))
421 (unless (constant-continuation-p dimension)
422 (give-up-ir1-transform))
423 (let ((dim (continuation-value dimension)))
424 `(the (integer 0 ,dim) index)))
425 (deftransform %check-bound ((array dimension index) * *
426 :policy (and (> speed safety) (= safety 0)))
431 ;;; SVREF, %SVSET, SCHAR, %SCHARSET, CHAR,
432 ;;; %CHARSET, SBIT, %SBITSET, BIT, %BITSET
433 ;;; -- source transforms.
435 ;;; We convert all typed array accessors into aref and %aset with type
436 ;;; assertions on the array.
437 (macrolet ((define-frob (reffer setter type)
439 (def-source-transform ,reffer (a &rest i)
442 `(aref (the ,',type ,a) ,@i)))
443 (def-source-transform ,setter (a &rest i)
446 `(%aset (the ,',type ,a) ,@i))))))
447 (define-frob svref %svset simple-vector)
448 (define-frob schar %scharset simple-string)
449 (define-frob char %charset string)
450 (define-frob sbit %sbitset (simple-array bit))
451 (define-frob bit %bitset (array bit)))
453 (macrolet (;; This is a handy macro for computing the row-major index
454 ;; given a set of indices. We wrap each index with a call
455 ;; to %CHECK-BOUND to ensure that everything works out
456 ;; correctly. We can wrap all the interior arithmetic with
457 ;; TRULY-THE INDEX because we know the the resultant
458 ;; row-major index must be an index.
459 (with-row-major-index ((array indices index &optional new-value)
461 `(let (n-indices dims)
462 (dotimes (i (length ,indices))
463 (push (make-symbol (format nil "INDEX-~D" i)) n-indices)
464 (push (make-symbol (format nil "DIM-~D" i)) dims))
465 (setf n-indices (nreverse n-indices))
466 (setf dims (nreverse dims))
467 `(lambda (,',array ,@n-indices
468 ,@',(when new-value (list new-value)))
469 (let* (,@(let ((,index -1))
470 (mapcar #'(lambda (name)
471 `(,name (array-dimension
478 (do* ((dims dims (cdr dims))
479 (indices n-indices (cdr indices))
480 (last-dim nil (car dims))
481 (form `(%check-bound ,',array
493 ((null (cdr dims)) form)))))
496 ;; Just return the index after computing it.
497 (deftransform array-row-major-index ((array &rest indices))
498 (with-row-major-index (array indices index)
501 ;; Convert AREF and %ASET into a HAIRY-DATA-VECTOR-REF (or
502 ;; HAIRY-DATA-VECTOR-SET) with the set of indices replaced with the an
503 ;; expression for the row major index.
504 (deftransform aref ((array &rest indices))
505 (with-row-major-index (array indices index)
506 (hairy-data-vector-ref array index)))
507 (deftransform %aset ((array &rest stuff))
508 (let ((indices (butlast stuff)))
509 (with-row-major-index (array indices index new-value)
510 (hairy-data-vector-set array index new-value)))))
512 ;;; Just convert into a HAIRY-DATA-VECTOR-REF (or
513 ;;; HAIRY-DATA-VECTOR-SET) after checking that the index is inside the
514 ;;; array total size.
515 (deftransform row-major-aref ((array index))
516 `(hairy-data-vector-ref array
517 (%check-bound array (array-total-size array) index)))
518 (deftransform %set-row-major-aref ((array index new-value))
519 `(hairy-data-vector-set array
520 (%check-bound array (array-total-size array) index)
523 ;;;; bit-vector array operation canonicalization
525 ;;;; We convert all bit-vector operations to have the result array
526 ;;;; specified. This allows any result allocation to be open-coded,
527 ;;;; and eliminates the need for any VM-dependent transforms to handle
530 (dolist (fun '(bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1
531 bit-andc2 bit-orc1 bit-orc2))
532 ;; Make a result array if result is NIL or unsupplied.
533 (deftransform fun ((bit-array-1 bit-array-2 &optional result-bit-array)
534 '(bit-vector bit-vector &optional null) '*
536 :policy (>= speed space))
537 `(,fun bit-array-1 bit-array-2
538 (make-array (length bit-array-1) :element-type 'bit)))
539 ;; If result is T, make it the first arg.
540 (deftransform fun ((bit-array-1 bit-array-2 result-bit-array)
541 '(bit-vector bit-vector (member t)) '*
543 `(,fun bit-array-1 bit-array-2 bit-array-1)))
545 ;;; Similar for BIT-NOT, but there is only one arg...
546 (deftransform bit-not ((bit-array-1 &optional result-bit-array)
547 (bit-vector &optional null) *
548 :policy (>= speed space))
549 '(bit-not bit-array-1
550 (make-array (length bit-array-1) :element-type 'bit)))
551 (deftransform bit-not ((bit-array-1 result-bit-array)
552 (bit-vector (constant-argument t)))
553 '(bit-not bit-array-1 bit-array-1))
554 ;;; FIXME: What does (CONSTANT-ARGUMENT T) mean? Is it the same thing
555 ;;; as (CONSTANT-ARGUMENT (MEMBER T)), or does it mean any constant
558 ;;; Pick off some constant cases.
559 (deftransform array-header-p ((array) (array))
560 (let ((type (continuation-type array)))
561 (declare (optimize (safety 3)))
562 (unless (array-type-p type)
563 (give-up-ir1-transform))
564 (let ((dims (array-type-dimensions type)))
565 (cond ((csubtypep type (specifier-type '(simple-array * (*))))
568 ((and (listp dims) (> (length dims) 1))
569 ;; Multi-dimensional array, will have a header.
572 (give-up-ir1-transform))))))