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