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