protect against read-time package-lock circumvention from LOCKED::(BAR)
[sbcl.git] / src / compiler / array-tran.lisp
1 ;;;; array-specific optimizers and transforms
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!C")
13 \f
14 ;;;; utilities for optimizing array operations
15
16 ;;; Return UPGRADED-ARRAY-ELEMENT-TYPE for LVAR, or do
17 ;;; GIVE-UP-IR1-TRANSFORM if the upgraded element type can't be
18 ;;; determined.
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)))
25
26 (defun upgraded-element-type-specifier (lvar)
27   (type-specifier (array-type-upgraded-element-type (lvar-type lvar))))
28
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
33 ;;; as it gets.)
34 (defun array-type-upgraded-element-type (type)
35   (typecase 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
40     ;; array type.
41     (array-type
42      (values (array-type-specialized-element-type type) nil))
43     ;; Deal with intersection types (bug #316078)
44     (intersection-type
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
54            ;; same element type.
55            (cond
56              ((eq cur-type *wild-type*)
57               nil)
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.
64               ;;
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))
70                  element-supertypes)))
71        (values element-type
72                (when (and (eq *wild-type* element-type) element-supertypes)
73                  (apply #'type-intersection element-supertypes)))))
74     (union-type
75      (let ((union-types (union-type-types type))
76            (element-type nil)
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)
81            (cond
82              ((eq element-type *wild-type*)
83               nil)
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))
97                  element-supertypes)))
98        (values element-type
99                (when (eq *wild-type* element-type)
100                  (apply #'type-union element-supertypes)))))
101     (member-type
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)))))
105     (t
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,
109      ;; 2002-08-21
110      (values *wild-type* nil))))
111
112 (defun array-type-declared-element-type (type)
113   (if (array-type-p type)
114       (array-type-element-type type)
115       *wild-type*))
116
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
119 ;;; functions.
120 (defun assert-new-value-type (new-value array)
121   (let ((type (lvar-type array)))
122     (when (array-type-p type)
123       (assert-lvar-type
124        new-value
125        (array-type-specialized-element-type type)
126        (lexenv-policy (node-lexenv (lvar-dest new-value))))))
127   (lvar-type new-value))
128
129 ;;; Return true if ARG is NIL, or is a constant-lvar whose
130 ;;; value is NIL, false otherwise.
131 (defun unsupplied-or-nil (arg)
132   (declare (type (or lvar null) arg))
133   (or (not arg)
134       (and (constant-lvar-p arg)
135            (not (lvar-value arg)))))
136
137 (defun supplied-and-true (arg)
138   (and arg
139        (constant-lvar-p arg)
140        (lvar-value arg)
141        t))
142 \f
143 ;;;; DERIVE-TYPE optimizers
144
145 ;;; Array operations that use a specific number of indices implicitly
146 ;;; assert that the array is of that rank.
147 (defun assert-array-rank (array rank)
148   (assert-lvar-type
149    array
150    (specifier-type `(array * ,(make-list rank :initial-element '*)))
151    (lexenv-policy (node-lexenv (lvar-dest array)))))
152
153 (defun derive-aref-type (array)
154   (multiple-value-bind (uaet other)
155       (array-type-upgraded-element-type (lvar-type array))
156     (or other uaet)))
157
158 (defoptimizer (array-in-bounds-p derive-type) ((array &rest indices))
159   (assert-array-rank array (length indices))
160   *universal-type*)
161
162 (deftransform array-in-bounds-p ((array &rest subscripts))
163   (flet ((give-up ()
164            (give-up-ir1-transform
165             "~@<lower array bounds unknown or negative and upper bounds not ~
166              negative~:@>"))
167          (bound-known-p (x)
168            (integerp x))) ; might be NIL or *
169     (block nil
170       (let ((dimensions (array-type-dimensions-or-give-up
171                          (lvar-conservative-type array))))
172         ;; shortcut for zero dimensions
173         (when (some (lambda (dim)
174                       (and (bound-known-p dim) (zerop dim)))
175                     dimensions)
176           (return nil))
177         ;; we first collect the subscripts LVARs' bounds and see whether
178         ;; we can already decide on the result of the optimization without
179         ;; even taking a look at the dimensions.
180         (flet ((subscript-bounds (subscript)
181                  (let* ((type1 (lvar-type subscript))
182                         (type2 (if (csubtypep type1 (specifier-type 'integer))
183                                    (weaken-integer-type type1)
184                                    (give-up)))
185                         (low (numeric-type-low type2))
186                         (high (numeric-type-high type2)))
187                    (cond
188                      ((and (or (not (bound-known-p low)) (minusp low))
189                            (or (not (bound-known-p high)) (not (minusp high))))
190                       ;; can't be sure about the lower bound and the upper bound
191                       ;; does not give us a definite clue either.
192                       (give-up))
193                      ((and (bound-known-p high) (minusp high))
194                       (return nil))     ; definitely below lower bound (zero).
195                      (t
196                       (cons low high))))))
197           (let* ((subscripts-bounds (mapcar #'subscript-bounds subscripts))
198                  (subscripts-lower-bound (mapcar #'car subscripts-bounds))
199                  (subscripts-upper-bound (mapcar #'cdr subscripts-bounds))
200                  (in-bounds 0))
201             (mapcar (lambda (low high dim)
202                       (cond
203                         ;; first deal with infinite bounds
204                         ((some (complement #'bound-known-p) (list low high dim))
205                          (when (and (bound-known-p dim) (bound-known-p low) (<= dim low))
206                            (return nil)))
207                         ;; now we know all bounds
208                         ((>= low dim)
209                          (return nil))
210                         ((< high dim)
211                          (aver (not (minusp low)))
212                          (incf in-bounds))
213                         (t
214                          (give-up))))
215                     subscripts-lower-bound
216                     subscripts-upper-bound
217                     dimensions)
218             (if (eql in-bounds (length dimensions))
219                 t
220                 (give-up))))))))
221
222 (defoptimizer (aref derive-type) ((array &rest indices) node)
223   (assert-array-rank array (length indices))
224   (derive-aref-type array))
225
226 (defoptimizer (%aset derive-type) ((array &rest stuff))
227   (assert-array-rank array (1- (length stuff)))
228   (assert-new-value-type (car (last stuff)) array))
229
230 (macrolet ((define (name)
231              `(defoptimizer (,name derive-type) ((array index))
232                 (derive-aref-type array))))
233   (define hairy-data-vector-ref)
234   (define hairy-data-vector-ref/check-bounds)
235   (define data-vector-ref))
236
237 #!+(or x86 x86-64)
238 (defoptimizer (data-vector-ref-with-offset derive-type) ((array index offset))
239   (derive-aref-type array))
240
241 (macrolet ((define (name)
242              `(defoptimizer (,name derive-type) ((array index new-value))
243                 (assert-new-value-type new-value array))))
244   (define hairy-data-vector-set)
245   (define hairy-data-vector-set/check-bounds)
246   (define data-vector-set))
247
248 #!+(or x86 x86-64)
249 (defoptimizer (data-vector-set-with-offset derive-type) ((array index offset new-value))
250   (assert-new-value-type new-value array))
251
252 ;;; Figure out the type of the data vector if we know the argument
253 ;;; element type.
254 (defun derive-%with-array-data/mumble-type (array)
255   (let ((atype (lvar-type array)))
256     (when (array-type-p atype)
257       (specifier-type
258        `(simple-array ,(type-specifier
259                         (array-type-specialized-element-type atype))
260                       (*))))))
261 (defoptimizer (%with-array-data derive-type) ((array start end))
262   (derive-%with-array-data/mumble-type array))
263 (defoptimizer (%with-array-data/fp derive-type) ((array start end))
264   (derive-%with-array-data/mumble-type array))
265
266 (defoptimizer (array-row-major-index derive-type) ((array &rest indices))
267   (assert-array-rank array (length indices))
268   *universal-type*)
269
270 (defoptimizer (row-major-aref derive-type) ((array index))
271   (derive-aref-type array))
272
273 (defoptimizer (%set-row-major-aref derive-type) ((array index new-value))
274   (assert-new-value-type new-value array))
275
276 (defoptimizer (make-array derive-type)
277               ((dims &key initial-element element-type initial-contents
278                 adjustable fill-pointer displaced-index-offset displaced-to))
279   (let* ((simple (and (unsupplied-or-nil adjustable)
280                       (unsupplied-or-nil displaced-to)
281                       (unsupplied-or-nil fill-pointer)))
282          (spec
283           (or `(,(if simple 'simple-array 'array)
284                  ,(cond ((not element-type) t)
285                         ((constant-lvar-p element-type)
286                          (let ((ctype (careful-specifier-type
287                                        (lvar-value element-type))))
288                            (cond
289                              ((or (null ctype) (unknown-type-p ctype)) '*)
290                              (t (sb!xc:upgraded-array-element-type
291                                  (lvar-value element-type))))))
292                         (t
293                          '*))
294                  ,(cond ((constant-lvar-p dims)
295                          (let* ((val (lvar-value dims))
296                                 (cdims (if (listp val) val (list val))))
297                            (if simple
298                                cdims
299                                (length cdims))))
300                         ((csubtypep (lvar-type dims)
301                                     (specifier-type 'integer))
302                          '(*))
303                         (t
304                          '*)))
305               'array)))
306     (if (and (not simple)
307              (or (supplied-and-true adjustable)
308                  (supplied-and-true displaced-to)
309                  (supplied-and-true fill-pointer)))
310         (careful-specifier-type `(and ,spec (not simple-array)))
311         (careful-specifier-type spec))))
312 \f
313 ;;;; constructors
314
315 ;;; Convert VECTOR into a MAKE-ARRAY.
316 (define-source-transform vector (&rest elements)
317   `(make-array ,(length elements) :initial-contents (list ,@elements)))
318
319 ;;; Just convert it into a MAKE-ARRAY.
320 (deftransform make-string ((length &key
321                                    (element-type 'character)
322                                    (initial-element
323                                     #.*default-init-char-form*)))
324   `(the simple-string (make-array (the index length)
325                        :element-type element-type
326                        ,@(when initial-element
327                            '(:initial-element initial-element)))))
328
329 (defun rewrite-initial-contents (rank initial-contents env)
330   (if (plusp rank)
331       (if (and (consp initial-contents)
332                (member (car initial-contents) '(list vector sb!impl::backq-list)))
333           `(list ,@(mapcar (lambda (dim)
334                              (rewrite-initial-contents (1- rank) dim env))
335                            (cdr initial-contents)))
336           initial-contents)
337       ;; This is the important bit: once we are past the level of
338       ;; :INITIAL-CONTENTS that relates to the array structure, reinline LIST
339       ;; and VECTOR so that nested DX isn't screwed up.
340       `(locally (declare (inline list vector))
341          ,initial-contents)))
342
343 ;;; Prevent open coding DIMENSION and :INITIAL-CONTENTS arguments, so that we
344 ;;; can pick them apart in the DEFTRANSFORMS, and transform '(3) style
345 ;;; dimensions to integer args directly.
346 (define-source-transform make-array (dimensions &rest keyargs &environment env)
347   (if (or (and (fun-lexically-notinline-p 'list)
348                (fun-lexically-notinline-p 'vector))
349           (oddp (length keyargs)))
350       (values nil t)
351       (multiple-value-bind (new-dimensions rank)
352           (flet ((constant-dims (dimensions)
353                    (let* ((dims (constant-form-value dimensions env))
354                           (canon (if (listp dims) dims (list dims)))
355                           (rank (length canon)))
356                      (values (if (= rank 1)
357                                  (list 'quote (car canon))
358                                  (list 'quote canon))
359                              rank))))
360             (cond ((sb!xc:constantp dimensions env)
361                    (constant-dims dimensions))
362                   ((and (consp dimensions) (eq 'list dimensions))
363                    (values dimensions (length (cdr dimensions))))
364                   (t
365                    (values dimensions nil))))
366         (let ((initial-contents (getf keyargs :initial-contents)))
367           (when (and initial-contents rank)
368             (setf (getf keyargs :initial-contents)
369                   (rewrite-initial-contents rank initial-contents env))))
370         `(locally (declare (notinline list vector))
371            (make-array ,new-dimensions ,@keyargs)))))
372
373 ;;; This baby is a bit of a monster, but it takes care of any MAKE-ARRAY
374 ;;; call which creates a vector with a known element type -- and tries
375 ;;; to do a good job with all the different ways it can happen.
376 (defun transform-make-array-vector (length element-type initial-element
377                                     initial-contents call)
378   (aver (or (not element-type) (constant-lvar-p element-type)))
379   (let* ((c-length (when (constant-lvar-p length)
380                      (lvar-value length)))
381          (elt-spec (if element-type
382                        (lvar-value element-type)
383                        t))
384          (elt-ctype (ir1-transform-specifier-type elt-spec))
385          (saetp (if (unknown-type-p elt-ctype)
386                     (give-up-ir1-transform "~S is an unknown type: ~S"
387                                            :element-type elt-spec)
388                     (find-saetp-by-ctype elt-ctype)))
389          (default-initial-element (sb!vm:saetp-initial-element-default saetp))
390          (n-bits (sb!vm:saetp-n-bits saetp))
391          (typecode (sb!vm:saetp-typecode saetp))
392          (n-pad-elements (sb!vm:saetp-n-pad-elements saetp))
393          (n-words-form
394           (if c-length
395               (ceiling (* (+ c-length n-pad-elements) n-bits)
396                        sb!vm:n-word-bits)
397               (let ((padded-length-form (if (zerop n-pad-elements)
398                                             'length
399                                             `(+ length ,n-pad-elements))))
400                 (cond
401                   ((= n-bits 0) 0)
402                   ((>= n-bits sb!vm:n-word-bits)
403                    `(* ,padded-length-form
404                        ;; i.e., not RATIO
405                        ,(the fixnum (/ n-bits sb!vm:n-word-bits))))
406                   (t
407                    (let ((n-elements-per-word (/ sb!vm:n-word-bits n-bits)))
408                      (declare (type index n-elements-per-word)) ; i.e., not RATIO
409                      `(ceiling ,padded-length-form ,n-elements-per-word)))))))
410          (result-spec
411           `(simple-array ,(sb!vm:saetp-specifier saetp) (,(or c-length '*))))
412          (alloc-form
413           `(truly-the ,result-spec
414                       (allocate-vector ,typecode (the index length) ,n-words-form))))
415     (cond ((and initial-element initial-contents)
416            (abort-ir1-transform "Both ~S and ~S specified."
417                                 :initial-contents :initial-element))
418           ;; :INITIAL-CONTENTS (LIST ...), (VECTOR ...) and `(1 1 ,x) with a
419           ;; constant LENGTH.
420           ((and initial-contents c-length
421                 (lvar-matches initial-contents
422                               :fun-names '(list vector sb!impl::backq-list)
423                               :arg-count c-length))
424            (let ((parameters (eliminate-keyword-args
425                               call 1 '((:element-type element-type)
426                                        (:initial-contents initial-contents))))
427                  (elt-vars (make-gensym-list c-length))
428                  (lambda-list '(length)))
429              (splice-fun-args initial-contents :any c-length)
430              (dolist (p parameters)
431                (setf lambda-list
432                      (append lambda-list
433                              (if (eq p 'initial-contents)
434                                  elt-vars
435                                  (list p)))))
436              `(lambda ,lambda-list
437                 (declare (type ,elt-spec ,@elt-vars)
438                          (ignorable ,@lambda-list))
439                 (truly-the ,result-spec
440                  (initialize-vector ,alloc-form ,@elt-vars)))))
441           ;; constant :INITIAL-CONTENTS and LENGTH
442           ((and initial-contents c-length (constant-lvar-p initial-contents))
443            (let ((contents (lvar-value initial-contents)))
444              (unless (= c-length (length contents))
445                (abort-ir1-transform "~S has ~S elements, vector length is ~S."
446                                     :initial-contents (length contents) c-length))
447              (let ((parameters (eliminate-keyword-args
448                                 call 1 '((:element-type element-type)
449                                          (:initial-contents initial-contents)))))
450                `(lambda (length ,@parameters)
451                   (declare (ignorable ,@parameters))
452                   (truly-the ,result-spec
453                    (initialize-vector ,alloc-form
454                                       ,@(map 'list (lambda (elt)
455                                                      `(the ,elt-spec ',elt))
456                                              contents)))))))
457           ;; any other :INITIAL-CONTENTS
458           (initial-contents
459            (let ((parameters (eliminate-keyword-args
460                               call 1 '((:element-type element-type)
461                                        (:initial-contents initial-contents)))))
462              `(lambda (length ,@parameters)
463                 (declare (ignorable ,@parameters))
464                 (unless (= length (length initial-contents))
465                   (error "~S has ~S elements, vector length is ~S."
466                          :initial-contents (length initial-contents) length))
467                 (truly-the ,result-spec
468                            (replace ,alloc-form initial-contents)))))
469           ;; :INITIAL-ELEMENT, not EQL to the default
470           ((and initial-element
471                 (or (not (constant-lvar-p initial-element))
472                     (not (eql default-initial-element (lvar-value initial-element)))))
473            (let ((parameters (eliminate-keyword-args
474                               call 1 '((:element-type element-type)
475                                        (:initial-element initial-element))))
476                  (init (if (constant-lvar-p initial-element)
477                            (list 'quote (lvar-value initial-element))
478                            'initial-element)))
479              `(lambda (length ,@parameters)
480                 (declare (ignorable ,@parameters))
481                 (truly-the ,result-spec
482                            (fill ,alloc-form (the ,elt-spec ,init))))))
483           ;; just :ELEMENT-TYPE, or maybe with :INITIAL-ELEMENT EQL to the
484           ;; default
485           (t
486            #-sb-xc-host
487            (unless (ctypep default-initial-element elt-ctype)
488              ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE
489              ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If
490              ;; INITIAL-ELEMENT is not supplied, the consequences of later
491              ;; reading an uninitialized element of new-array are undefined,"
492              ;; so this could be legal code as long as the user plans to
493              ;; write before he reads, and if he doesn't we're free to do
494              ;; anything we like. But in case the user doesn't know to write
495              ;; elements before he reads elements (or to read manuals before
496              ;; he writes code:-), we'll signal a STYLE-WARNING in case he
497              ;; didn't realize this.
498              (if initial-element
499                  (compiler-warn "~S ~S is not a ~S"
500                                 :initial-element default-initial-element
501                                 elt-spec)
502                  (compiler-style-warn "The default initial element ~S is not a ~S."
503                                       default-initial-element
504                                       elt-spec)))
505            (let ((parameters (eliminate-keyword-args
506                               call 1 '((:element-type element-type)
507                                        (:initial-element initial-element)))))
508              `(lambda (length ,@parameters)
509                 (declare (ignorable ,@parameters))
510                 ,alloc-form))))))
511
512 ;;; IMPORTANT: The order of these three MAKE-ARRAY forms matters: the least
513 ;;; specific must come first, otherwise suboptimal transforms will result for
514 ;;; some forms.
515
516 (deftransform make-array ((dims &key initial-element element-type
517                                      adjustable fill-pointer)
518                           (t &rest *))
519   (when (null initial-element)
520     (give-up-ir1-transform))
521   (let* ((eltype (cond ((not element-type) t)
522                        ((not (constant-lvar-p element-type))
523                         (give-up-ir1-transform
524                          "ELEMENT-TYPE is not constant."))
525                        (t
526                         (lvar-value element-type))))
527          (eltype-type (ir1-transform-specifier-type eltype))
528          (saetp (find-if (lambda (saetp)
529                            (csubtypep eltype-type (sb!vm:saetp-ctype saetp)))
530                          sb!vm:*specialized-array-element-type-properties*))
531          (creation-form `(make-array dims
532                           :element-type ',(type-specifier (sb!vm:saetp-ctype saetp))
533                           ,@(when fill-pointer
534                                   '(:fill-pointer fill-pointer))
535                           ,@(when adjustable
536                                   '(:adjustable adjustable)))))
537
538     (unless saetp
539       (give-up-ir1-transform "ELEMENT-TYPE not found in *SAETP*: ~S" eltype))
540
541     (cond ((and (constant-lvar-p initial-element)
542                 (eql (lvar-value initial-element)
543                      (sb!vm:saetp-initial-element-default saetp)))
544            creation-form)
545           (t
546            ;; error checking for target, disabled on the host because
547            ;; (CTYPE-OF #\Null) is not possible.
548            #-sb-xc-host
549            (when (constant-lvar-p initial-element)
550              (let ((value (lvar-value initial-element)))
551                (cond
552                  ((not (ctypep value (sb!vm:saetp-ctype saetp)))
553                   ;; this case will cause an error at runtime, so we'd
554                   ;; better WARN about it now.
555                   (warn 'array-initial-element-mismatch
556                         :format-control "~@<~S is not a ~S (which is the ~
557                                          ~S of ~S).~@:>"
558                         :format-arguments
559                         (list
560                          value
561                          (type-specifier (sb!vm:saetp-ctype saetp))
562                          'upgraded-array-element-type
563                          eltype)))
564                  ((not (ctypep value eltype-type))
565                   ;; this case will not cause an error at runtime, but
566                   ;; it's still worth STYLE-WARNing about.
567                   (compiler-style-warn "~S is not a ~S."
568                                        value eltype)))))
569            `(let ((array ,creation-form))
570              (multiple-value-bind (vector)
571                  (%data-vector-and-index array 0)
572                (fill vector (the ,(sb!vm:saetp-specifier saetp) initial-element)))
573              array)))))
574
575 ;;; The list type restriction does not ensure that the result will be a
576 ;;; multi-dimensional array. But the lack of adjustable, fill-pointer,
577 ;;; and displaced-to keywords ensures that it will be simple.
578 ;;;
579 ;;; FIXME: should we generalize this transform to non-simple (though
580 ;;; non-displaced-to) arrays, given that we have %WITH-ARRAY-DATA to
581 ;;; deal with those? Maybe when the DEFTRANSFORM
582 ;;; %DATA-VECTOR-AND-INDEX in the VECTOR case problem is solved? --
583 ;;; CSR, 2002-07-01
584 (deftransform make-array ((dims &key
585                                 element-type initial-element initial-contents)
586                           (list &key
587                                 (:element-type (constant-arg *))
588                                 (:initial-element *)
589                                 (:initial-contents *))
590                           *
591                           :node call)
592   (block make-array
593     (when (lvar-matches dims :fun-names '(list) :arg-count 1)
594       (let ((length (car (splice-fun-args dims :any 1))))
595         (return-from make-array
596           (transform-make-array-vector length
597                                        element-type
598                                        initial-element
599                                        initial-contents
600                                        call))))
601     (unless (constant-lvar-p dims)
602       (give-up-ir1-transform
603        "The dimension list is not constant; cannot open code array creation."))
604     (let ((dims (lvar-value dims)))
605       (unless (every #'integerp dims)
606         (give-up-ir1-transform
607          "The dimension list contains something other than an integer: ~S"
608          dims))
609       (if (= (length dims) 1)
610           `(make-array ',(car dims)
611                        ,@(when element-type
612                                '(:element-type element-type))
613                        ,@(when initial-element
614                                '(:initial-element initial-element))
615                        ,@(when initial-contents
616                                '(:initial-contents initial-contents)))
617           (let* ((total-size (reduce #'* dims))
618                  (rank (length dims))
619                  (spec `(simple-array
620                          ,(cond ((null element-type) t)
621                                 ((and (constant-lvar-p element-type)
622                                       (ir1-transform-specifier-type
623                                        (lvar-value element-type)))
624                                  (sb!xc:upgraded-array-element-type
625                                   (lvar-value element-type)))
626                                 (t '*))
627                          ,(make-list rank :initial-element '*))))
628             `(let ((header (make-array-header sb!vm:simple-array-widetag ,rank))
629                    (data (make-array ,total-size
630                                      ,@(when element-type
631                                              '(:element-type element-type))
632                                      ,@(when initial-element
633                                              '(:initial-element initial-element)))))
634                ,@(when initial-contents
635                        ;; FIXME: This is could be open coded at least a bit too
636                        `((sb!impl::fill-data-vector data ',dims initial-contents)))
637                (setf (%array-fill-pointer header) ,total-size)
638                (setf (%array-fill-pointer-p header) nil)
639                (setf (%array-available-elements header) ,total-size)
640                (setf (%array-data-vector header) data)
641                (setf (%array-displaced-p header) nil)
642                (setf (%array-displaced-from header) nil)
643                ,@(let ((axis -1))
644                       (mapcar (lambda (dim)
645                                 `(setf (%array-dimension header ,(incf axis))
646                                        ,dim))
647                               dims))
648                (truly-the ,spec header)))))))
649
650 (deftransform make-array ((dims &key element-type initial-element initial-contents)
651                           (integer &key
652                                    (:element-type (constant-arg *))
653                                    (:initial-element *)
654                                    (:initial-contents *))
655                           *
656                           :node call)
657   (transform-make-array-vector dims
658                                element-type
659                                initial-element
660                                initial-contents
661                                call))
662 \f
663 ;;;; miscellaneous properties of arrays
664
665 ;;; Transforms for various array properties. If the property is know
666 ;;; at compile time because of a type spec, use that constant value.
667
668 ;;; Most of this logic may end up belonging in code/late-type.lisp;
669 ;;; however, here we also need the -OR-GIVE-UP for the transforms, and
670 ;;; maybe this is just too sloppy for actual type logic.  -- CSR,
671 ;;; 2004-02-18
672 (defun array-type-dimensions-or-give-up (type)
673   (labels ((maybe-array-type-dimensions (type)
674              (typecase type
675                (array-type
676                 (array-type-dimensions type))
677                (union-type
678                 (let* ((types (remove nil (mapcar #'maybe-array-type-dimensions
679                                                   (union-type-types type))))
680                        (result (car types)))
681                   (dolist (other (cdr types) result)
682                     (unless (equal result other)
683                       (give-up-ir1-transform
684                        "~@<dimensions of arrays in union type ~S do not match~:@>"
685                        (type-specifier type))))))
686                (intersection-type
687                 (let* ((types (remove nil (mapcar #'maybe-array-type-dimensions
688                                                   (intersection-type-types type))))
689                        (result (car types)))
690                   (dolist (other (cdr types) result)
691                     (unless (equal result other)
692                       (abort-ir1-transform
693                        "~@<dimensions of arrays in intersection type ~S do not match~:@>"
694                        (type-specifier type)))))))))
695     (or (maybe-array-type-dimensions type)
696         (give-up-ir1-transform
697          "~@<don't know how to extract array dimensions from type ~S~:@>"
698          (type-specifier type)))))
699
700 (defun conservative-array-type-complexp (type)
701   (typecase type
702     (array-type (array-type-complexp type))
703     (union-type
704      (let ((types (union-type-types type)))
705        (aver (> (length types) 1))
706        (let ((result (conservative-array-type-complexp (car types))))
707          (dolist (type (cdr types) result)
708            (unless (eq (conservative-array-type-complexp type) result)
709              (return-from conservative-array-type-complexp :maybe))))))
710     ;; FIXME: intersection type
711     (t :maybe)))
712
713 ;;; If we can tell the rank from the type info, use it instead.
714 (deftransform array-rank ((array))
715   (let ((array-type (lvar-type array)))
716     (let ((dims (array-type-dimensions-or-give-up array-type)))
717       (cond ((listp dims)
718              (length dims))
719             ((eq t (array-type-complexp array-type))
720              '(%array-rank array))
721             (t
722              `(if (array-header-p array)
723                   (%array-rank array)
724                   1))))))
725
726 ;;; If we know the dimensions at compile time, just use it. Otherwise,
727 ;;; if we can tell that the axis is in bounds, convert to
728 ;;; %ARRAY-DIMENSION (which just indirects the array header) or length
729 ;;; (if it's simple and a vector).
730 (deftransform array-dimension ((array axis)
731                                (array index))
732   (unless (constant-lvar-p axis)
733     (give-up-ir1-transform "The axis is not constant."))
734   ;; Dimensions may change thanks to ADJUST-ARRAY, so we need the
735   ;; conservative type.
736   (let ((array-type (lvar-conservative-type array))
737         (axis (lvar-value axis)))
738     (let ((dims (array-type-dimensions-or-give-up array-type)))
739       (unless (listp dims)
740         (give-up-ir1-transform
741          "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime."))
742       (unless (> (length dims) axis)
743         (abort-ir1-transform "The array has dimensions ~S, ~W is too large."
744                              dims
745                              axis))
746       (let ((dim (nth axis dims)))
747         (cond ((integerp dim)
748                dim)
749               ((= (length dims) 1)
750                (ecase (conservative-array-type-complexp array-type)
751                  ((t)
752                   '(%array-dimension array 0))
753                  ((nil)
754                   '(vector-length array))
755                  ((:maybe)
756                   `(if (array-header-p array)
757                        (%array-dimension array axis)
758                        (vector-length array)))))
759               (t
760                '(%array-dimension array axis)))))))
761
762 ;;; If the length has been declared and it's simple, just return it.
763 (deftransform length ((vector)
764                       ((simple-array * (*))))
765   (let ((type (lvar-type vector)))
766     (let ((dims (array-type-dimensions-or-give-up type)))
767       (unless (and (listp dims) (integerp (car dims)))
768         (give-up-ir1-transform
769          "Vector length is unknown, must call LENGTH at runtime."))
770       (car dims))))
771
772 ;;; All vectors can get their length by using VECTOR-LENGTH. If it's
773 ;;; simple, it will extract the length slot from the vector. It it's
774 ;;; complex, it will extract the fill pointer slot from the array
775 ;;; header.
776 (deftransform length ((vector) (vector))
777   '(vector-length vector))
778
779 ;;; If a simple array with known dimensions, then VECTOR-LENGTH is a
780 ;;; compile-time constant.
781 (deftransform vector-length ((vector))
782   (let ((vtype (lvar-type vector)))
783     (let ((dim (first (array-type-dimensions-or-give-up vtype))))
784       (when (eq dim '*)
785         (give-up-ir1-transform))
786       (when (conservative-array-type-complexp vtype)
787         (give-up-ir1-transform))
788       dim)))
789
790 ;;; Again, if we can tell the results from the type, just use it.
791 ;;; Otherwise, if we know the rank, convert into a computation based
792 ;;; on array-dimension. We can wrap a TRULY-THE INDEX around the
793 ;;; multiplications because we know that the total size must be an
794 ;;; INDEX.
795 (deftransform array-total-size ((array)
796                                 (array))
797   (let ((array-type (lvar-type array)))
798     (let ((dims (array-type-dimensions-or-give-up array-type)))
799       (unless (listp dims)
800         (give-up-ir1-transform "can't tell the rank at compile time"))
801       (if (member '* dims)
802           (do ((form 1 `(truly-the index
803                                    (* (array-dimension array ,i) ,form)))
804                (i 0 (1+ i)))
805               ((= i (length dims)) form))
806           (reduce #'* dims)))))
807
808 ;;; Only complex vectors have fill pointers.
809 (deftransform array-has-fill-pointer-p ((array))
810   (let ((array-type (lvar-type array)))
811     (let ((dims (array-type-dimensions-or-give-up array-type)))
812       (if (and (listp dims) (not (= (length dims) 1)))
813           nil
814           (ecase (conservative-array-type-complexp array-type)
815             ((t)
816              t)
817             ((nil)
818              nil)
819             ((:maybe)
820              (give-up-ir1-transform
821               "The array type is ambiguous; must call ~
822                ARRAY-HAS-FILL-POINTER-P at runtime.")))))))
823
824 ;;; Primitive used to verify indices into arrays. If we can tell at
825 ;;; compile-time or we are generating unsafe code, don't bother with
826 ;;; the VOP.
827 (deftransform %check-bound ((array dimension index) * * :node node)
828   (cond ((policy node (= insert-array-bounds-checks 0))
829          'index)
830         ((not (constant-lvar-p dimension))
831          (give-up-ir1-transform))
832         (t
833          (let ((dim (lvar-value dimension)))
834            ;; FIXME: Can SPEED > SAFETY weaken this check to INTEGER?
835            `(the (integer 0 (,dim)) index)))))
836 \f
837 ;;;; WITH-ARRAY-DATA
838
839 ;;; This checks to see whether the array is simple and the start and
840 ;;; end are in bounds. If so, it proceeds with those values.
841 ;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that %WITH-ARRAY-DATA
842 ;;; may be further optimized.
843 ;;;
844 ;;; Given any ARRAY, bind DATA-VAR to the array's data vector and
845 ;;; START-VAR and END-VAR to the start and end of the designated
846 ;;; portion of the data vector. SVALUE and EVALUE are any start and
847 ;;; end specified to the original operation, and are factored into the
848 ;;; bindings of START-VAR and END-VAR. OFFSET-VAR is the cumulative
849 ;;; offset of all displacements encountered, and does not include
850 ;;; SVALUE.
851 ;;;
852 ;;; When FORCE-INLINE is set, the underlying %WITH-ARRAY-DATA form is
853 ;;; forced to be inline, overriding the ordinary judgment of the
854 ;;; %WITH-ARRAY-DATA DEFTRANSFORMs. Ordinarily the DEFTRANSFORMs are
855 ;;; fairly picky about their arguments, figuring that if you haven't
856 ;;; bothered to get all your ducks in a row, you probably don't care
857 ;;; that much about speed anyway! But in some cases it makes sense to
858 ;;; do type testing inside %WITH-ARRAY-DATA instead of outside, and
859 ;;; the DEFTRANSFORM can't tell that that's going on, so it can make
860 ;;; sense to use FORCE-INLINE option in that case.
861 (def!macro with-array-data (((data-var array &key offset-var)
862                              (start-var &optional (svalue 0))
863                              (end-var &optional (evalue nil))
864                              &key force-inline check-fill-pointer)
865                             &body forms
866                             &environment env)
867   (once-only ((n-array array)
868               (n-svalue `(the index ,svalue))
869               (n-evalue `(the (or index null) ,evalue)))
870     (let ((check-bounds (policy env (plusp insert-array-bounds-checks))))
871       `(multiple-value-bind (,data-var
872                              ,start-var
873                              ,end-var
874                              ,@(when offset-var `(,offset-var)))
875            (if (not (array-header-p ,n-array))
876                (let ((,n-array ,n-array))
877                  (declare (type (simple-array * (*)) ,n-array))
878                  ,(once-only ((n-len (if check-fill-pointer
879                                          `(length ,n-array)
880                                          `(array-total-size ,n-array)))
881                               (n-end `(or ,n-evalue ,n-len)))
882                              (if check-bounds
883                                  `(if (<= 0 ,n-svalue ,n-end ,n-len)
884                                       (values ,n-array ,n-svalue ,n-end 0)
885                                       ,(if check-fill-pointer
886                                            `(sequence-bounding-indices-bad-error ,n-array ,n-svalue ,n-evalue)
887                                            `(array-bounding-indices-bad-error ,n-array ,n-svalue ,n-evalue)))
888                                  `(values ,n-array ,n-svalue ,n-end 0))))
889                ,(if force-inline
890                     `(%with-array-data-macro ,n-array ,n-svalue ,n-evalue
891                                              :check-bounds ,check-bounds
892                                              :check-fill-pointer ,check-fill-pointer)
893                     (if check-fill-pointer
894                         `(%with-array-data/fp ,n-array ,n-svalue ,n-evalue)
895                         `(%with-array-data ,n-array ,n-svalue ,n-evalue))))
896          ,@forms))))
897
898 ;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in
899 ;;; DEFTRANSFORMs and DEFUNs.
900 (def!macro %with-array-data-macro (array
901                                    start
902                                    end
903                                    &key
904                                    (element-type '*)
905                                    check-bounds
906                                    check-fill-pointer)
907   (with-unique-names (size defaulted-end data cumulative-offset)
908     `(let* ((,size ,(if check-fill-pointer
909                         `(length ,array)
910                         `(array-total-size ,array)))
911             (,defaulted-end (or ,end ,size)))
912        ,@(when check-bounds
913                `((unless (<= ,start ,defaulted-end ,size)
914                    ,(if check-fill-pointer
915                         `(sequence-bounding-indices-bad-error ,array ,start ,end)
916                         `(array-bounding-indices-bad-error ,array ,start ,end)))))
917        (do ((,data ,array (%array-data-vector ,data))
918             (,cumulative-offset 0
919                                 (+ ,cumulative-offset
920                                    (%array-displacement ,data))))
921            ((not (array-header-p ,data))
922             (values (the (simple-array ,element-type 1) ,data)
923                     (the index (+ ,cumulative-offset ,start))
924                     (the index (+ ,cumulative-offset ,defaulted-end))
925                     (the index ,cumulative-offset)))
926          (declare (type index ,cumulative-offset))))))
927
928 (defun transform-%with-array-data/muble (array node check-fill-pointer)
929   (let ((element-type (upgraded-element-type-specifier-or-give-up array))
930         (type (lvar-type array))
931         (check-bounds (policy node (plusp insert-array-bounds-checks))))
932     (if (and (array-type-p type)
933              (not (array-type-complexp type))
934              (listp (array-type-dimensions type))
935              (not (null (cdr (array-type-dimensions type)))))
936         ;; If it's a simple multidimensional array, then just return
937         ;; its data vector directly rather than going through
938         ;; %WITH-ARRAY-DATA-MACRO. SBCL doesn't generally generate
939         ;; code that would use this currently, but we have encouraged
940         ;; users to use WITH-ARRAY-DATA and we may use it ourselves at
941         ;; some point in the future for optimized libraries or
942         ;; similar.
943         (if check-bounds
944             `(let* ((data (truly-the (simple-array ,element-type (*))
945                                      (%array-data-vector array)))
946                     (len (length data))
947                     (real-end (or end len)))
948                (unless (<= 0 start data-end lend)
949                  (sequence-bounding-indices-bad-error array start end))
950                (values data 0 real-end 0))
951             `(let ((data (truly-the (simple-array ,element-type (*))
952                                     (%array-data-vector array))))
953                (values data 0 (or end (length data)) 0)))
954         `(%with-array-data-macro array start end
955                                  :check-fill-pointer ,check-fill-pointer
956                                  :check-bounds ,check-bounds
957                                  :element-type ,element-type))))
958
959 ;; It might very well be reasonable to allow general ARRAY here, I
960 ;; just haven't tried to understand the performance issues involved.
961 ;; -- WHN, and also CSR 2002-05-26
962 (deftransform %with-array-data ((array start end)
963                                 ((or vector simple-array) index (or index null) t)
964                                 *
965                                 :node node
966                                 :policy (> speed space))
967   "inline non-SIMPLE-vector-handling logic"
968   (transform-%with-array-data/muble array node nil))
969 (deftransform %with-array-data/fp ((array start end)
970                                 ((or vector simple-array) index (or index null) t)
971                                 *
972                                 :node node
973                                 :policy (> speed space))
974   "inline non-SIMPLE-vector-handling logic"
975   (transform-%with-array-data/muble array node t))
976 \f
977 ;;;; array accessors
978
979 ;;; We convert all typed array accessors into AREF and %ASET with type
980 ;;; assertions on the array.
981 (macrolet ((define-bit-frob (reffer setter simplep)
982              `(progn
983                 (define-source-transform ,reffer (a &rest i)
984                   `(aref (the (,',(if simplep 'simple-array 'array)
985                                   bit
986                                   ,(mapcar (constantly '*) i))
987                            ,a) ,@i))
988                 (define-source-transform ,setter (a &rest i)
989                   `(%aset (the (,',(if simplep 'simple-array 'array)
990                                    bit
991                                    ,(cdr (mapcar (constantly '*) i)))
992                             ,a) ,@i)))))
993   (define-bit-frob sbit %sbitset t)
994   (define-bit-frob bit %bitset nil))
995 (macrolet ((define-frob (reffer setter type)
996              `(progn
997                 (define-source-transform ,reffer (a i)
998                   `(aref (the ,',type ,a) ,i))
999                 (define-source-transform ,setter (a i v)
1000                   `(%aset (the ,',type ,a) ,i ,v)))))
1001   (define-frob svref %svset simple-vector)
1002   (define-frob schar %scharset simple-string)
1003   (define-frob char %charset string))
1004
1005 (macrolet (;; This is a handy macro for computing the row-major index
1006            ;; given a set of indices. We wrap each index with a call
1007            ;; to %CHECK-BOUND to ensure that everything works out
1008            ;; correctly. We can wrap all the interior arithmetic with
1009            ;; TRULY-THE INDEX because we know the resultant
1010            ;; row-major index must be an index.
1011            (with-row-major-index ((array indices index &optional new-value)
1012                                   &rest body)
1013              `(let (n-indices dims)
1014                 (dotimes (i (length ,indices))
1015                   (push (make-symbol (format nil "INDEX-~D" i)) n-indices)
1016                   (push (make-symbol (format nil "DIM-~D" i)) dims))
1017                 (setf n-indices (nreverse n-indices))
1018                 (setf dims (nreverse dims))
1019                 `(lambda (,',array ,@n-indices
1020                                    ,@',(when new-value (list new-value)))
1021                    (let* (,@(let ((,index -1))
1022                               (mapcar (lambda (name)
1023                                         `(,name (array-dimension
1024                                                  ,',array
1025                                                  ,(incf ,index))))
1026                                       dims))
1027                             (,',index
1028                              ,(if (null dims)
1029                                   0
1030                                 (do* ((dims dims (cdr dims))
1031                                       (indices n-indices (cdr indices))
1032                                       (last-dim nil (car dims))
1033                                       (form `(%check-bound ,',array
1034                                                            ,(car dims)
1035                                                            ,(car indices))
1036                                             `(truly-the
1037                                               index
1038                                               (+ (truly-the index
1039                                                             (* ,form
1040                                                                ,last-dim))
1041                                                  (%check-bound
1042                                                   ,',array
1043                                                   ,(car dims)
1044                                                   ,(car indices))))))
1045                                     ((null (cdr dims)) form)))))
1046                      ,',@body)))))
1047
1048   ;; Just return the index after computing it.
1049   (deftransform array-row-major-index ((array &rest indices))
1050     (with-row-major-index (array indices index)
1051       index))
1052
1053   ;; Convert AREF and %ASET into a HAIRY-DATA-VECTOR-REF (or
1054   ;; HAIRY-DATA-VECTOR-SET) with the set of indices replaced with the an
1055   ;; expression for the row major index.
1056   (deftransform aref ((array &rest indices))
1057     (with-row-major-index (array indices index)
1058       (hairy-data-vector-ref array index)))
1059
1060   (deftransform %aset ((array &rest stuff))
1061     (let ((indices (butlast stuff)))
1062       (with-row-major-index (array indices index new-value)
1063         (hairy-data-vector-set array index new-value)))))
1064
1065 ;; For AREF of vectors we do the bounds checking in the callee. This
1066 ;; lets us do a significantly more efficient check for simple-arrays
1067 ;; without bloating the code. If we already know the type of the array
1068 ;; with sufficient precision, skip directly to DATA-VECTOR-REF.
1069 (deftransform aref ((array index) (t t) * :node node)
1070   (let* ((type (lvar-type array))
1071          (element-ctype (array-type-upgraded-element-type type)))
1072     (cond
1073       ((and (array-type-p type)
1074             (null (array-type-complexp type))
1075             (not (eql element-ctype *wild-type*))
1076             (eql (length (array-type-dimensions type)) 1))
1077        (let* ((declared-element-ctype (array-type-declared-element-type type))
1078               (bare-form
1079                `(data-vector-ref array
1080                  (%check-bound array (array-dimension array 0) index))))
1081          (if (type= declared-element-ctype element-ctype)
1082              bare-form
1083              `(the ,(type-specifier declared-element-ctype) ,bare-form))))
1084       ((policy node (zerop insert-array-bounds-checks))
1085        `(hairy-data-vector-ref array index))
1086       (t `(hairy-data-vector-ref/check-bounds array index)))))
1087
1088 (deftransform %aset ((array index new-value) (t t t) * :node node)
1089   (if (policy node (zerop insert-array-bounds-checks))
1090       `(hairy-data-vector-set array index new-value)
1091       `(hairy-data-vector-set/check-bounds array index new-value)))
1092
1093 ;;; But if we find out later that there's some useful type information
1094 ;;; available, switch back to the normal one to give other transforms
1095 ;;; a stab at it.
1096 (macrolet ((define (name transform-to extra extra-type)
1097              (declare (ignore extra-type))
1098              `(deftransform ,name ((array index ,@extra))
1099                 (let* ((type (lvar-type array))
1100                        (element-type (array-type-upgraded-element-type type))
1101                        (declared-type (type-specifier
1102                                        (array-type-declared-element-type type))))
1103                   ;; If an element type has been declared, we want to
1104                   ;; use that information it for type checking (even
1105                   ;; if the access can't be optimized due to the array
1106                   ;; not being simple).
1107                   (when (and (eql element-type *wild-type*)
1108                              ;; This type logic corresponds to the special
1109                              ;; case for strings in HAIRY-DATA-VECTOR-REF
1110                              ;; (generic/vm-tran.lisp)
1111                              (not (csubtypep type (specifier-type 'simple-string))))
1112                     (when (or (not (array-type-p type))
1113                               ;; If it's a simple array, we might be able
1114                               ;; to inline the access completely.
1115                               (not (null (array-type-complexp type))))
1116                       (give-up-ir1-transform
1117                        "Upgraded element type of array is not known at compile time.")))
1118                   ,(if extra
1119                        ``(truly-the ,declared-type
1120                                     (,',transform-to array
1121                                                      (%check-bound array
1122                                                                    (array-dimension array 0)
1123                                                                    index)
1124                                                      (the ,declared-type ,@',extra)))
1125                        ``(the ,declared-type
1126                            (,',transform-to array
1127                                             (%check-bound array
1128                                                           (array-dimension array 0)
1129                                                           index))))))))
1130   (define hairy-data-vector-ref/check-bounds
1131       hairy-data-vector-ref nil nil)
1132   (define hairy-data-vector-set/check-bounds
1133       hairy-data-vector-set (new-value) (*)))
1134
1135 ;;; Just convert into a HAIRY-DATA-VECTOR-REF (or
1136 ;;; HAIRY-DATA-VECTOR-SET) after checking that the index is inside the
1137 ;;; array total size.
1138 (deftransform row-major-aref ((array index))
1139   `(hairy-data-vector-ref array
1140                           (%check-bound array (array-total-size array) index)))
1141 (deftransform %set-row-major-aref ((array index new-value))
1142   `(hairy-data-vector-set array
1143                           (%check-bound array (array-total-size array) index)
1144                           new-value))
1145 \f
1146 ;;;; bit-vector array operation canonicalization
1147 ;;;;
1148 ;;;; We convert all bit-vector operations to have the result array
1149 ;;;; specified. This allows any result allocation to be open-coded,
1150 ;;;; and eliminates the need for any VM-dependent transforms to handle
1151 ;;;; these cases.
1152
1153 (macrolet ((def (fun)
1154              `(progn
1155                (deftransform ,fun ((bit-array-1 bit-array-2
1156                                                 &optional result-bit-array)
1157                                    (bit-vector bit-vector &optional null) *
1158                                    :policy (>= speed space))
1159                  `(,',fun bit-array-1 bit-array-2
1160                    (make-array (array-dimension bit-array-1 0) :element-type 'bit)))
1161                ;; If result is T, make it the first arg.
1162                (deftransform ,fun ((bit-array-1 bit-array-2 result-bit-array)
1163                                    (bit-vector bit-vector (eql t)) *)
1164                  `(,',fun bit-array-1 bit-array-2 bit-array-1)))))
1165   (def bit-and)
1166   (def bit-ior)
1167   (def bit-xor)
1168   (def bit-eqv)
1169   (def bit-nand)
1170   (def bit-nor)
1171   (def bit-andc1)
1172   (def bit-andc2)
1173   (def bit-orc1)
1174   (def bit-orc2))
1175
1176 ;;; Similar for BIT-NOT, but there is only one arg...
1177 (deftransform bit-not ((bit-array-1 &optional result-bit-array)
1178                        (bit-vector &optional null) *
1179                        :policy (>= speed space))
1180   '(bit-not bit-array-1
1181             (make-array (array-dimension bit-array-1 0) :element-type 'bit)))
1182 (deftransform bit-not ((bit-array-1 result-bit-array)
1183                        (bit-vector (eql t)))
1184   '(bit-not bit-array-1 bit-array-1))
1185 \f
1186 ;;; Pick off some constant cases.
1187 (defoptimizer (array-header-p derive-type) ((array))
1188   (let ((type (lvar-type array)))
1189     (cond ((not (array-type-p type))
1190            ;; FIXME: use analogue of ARRAY-TYPE-DIMENSIONS-OR-GIVE-UP
1191            nil)
1192           (t
1193            (let ((dims (array-type-dimensions type)))
1194              (cond ((csubtypep type (specifier-type '(simple-array * (*))))
1195                     ;; no array header
1196                     (specifier-type 'null))
1197                    ((and (listp dims) (/= (length dims) 1))
1198                     ;; multi-dimensional array, will have a header
1199                     (specifier-type '(eql t)))
1200                    ((eql (array-type-complexp type) t)
1201                     (specifier-type '(eql t)))
1202                    (t
1203                     nil)))))))