0.8alpha.0.9:
[sbcl.git] / src / compiler / array-tran.lisp
index e94f70d..9b77313 100644 (file)
        element-type-specifier)))
 
 ;;; Array access functions return an object from the array, hence its
-;;; type will be asserted to be array element type.
-(defun extract-element-type (array)
-  (let ((type (continuation-type array)))
-    (if (array-type-p type)
-       (array-type-element-type type)
-       *universal-type*)))
-
-;;; Array access functions return an object from the array, hence its
 ;;; type is going to be the array upgraded element type.
 (defun extract-upgraded-element-type (array)
   (let ((type (continuation-type array)))
+    ;; Note that this IF mightn't be satisfied even if the runtime
+    ;; value is known to be a subtype of some specialized ARRAY, because
+    ;; we can have values declared e.g. (AND SIMPLE-VECTOR UNKNOWN-TYPE),
+    ;; which are represented in the compiler as INTERSECTION-TYPE, not
+    ;; array type.
     (if (array-type-p type)
        (array-type-specialized-element-type type)
-       *universal-type*)))
+       ;; KLUDGE: there is no good answer here, but at least
+       ;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be
+       ;; erroneously optimized (see generic/vm-tran.lisp) -- CSR,
+       ;; 2002-08-21
+       *wild-type*)))
 
 ;;; The ``new-value'' for array setters must fit in the array, and the
 ;;; return type is going to be the same as the new-value for SETF
 (defun assert-new-value-type (new-value array)
   (let ((type (continuation-type array)))
     (when (array-type-p type)
-      (assert-continuation-type new-value (array-type-element-type type))))
+      (assert-continuation-type
+       new-value
+       (array-type-specialized-element-type type)
+       (lexenv-policy (node-lexenv (continuation-dest new-value))))))
   (continuation-type new-value))
 
-;;; Return true if Arg is NIL, or is a constant-continuation whose
+(defun assert-array-complex (array)
+  (assert-continuation-type
+   array
+   (make-array-type :complexp t
+                    :element-type *wild-type*)
+   (lexenv-policy (node-lexenv (continuation-dest array)))))
+
+;;; Return true if ARG is NIL, or is a constant-continuation whose
 ;;; value is NIL, false otherwise.
 (defun unsupplied-or-nil (arg)
   (declare (type (or continuation null) arg))
@@ -64,7 +75,8 @@
 (defun assert-array-rank (array rank)
   (assert-continuation-type
    array
-   (specifier-type `(array * ,(make-list rank :initial-element '*)))))
+   (specifier-type `(array * ,(make-list rank :initial-element '*)))
+   (lexenv-policy (node-lexenv (continuation-dest array)))))
 
 (defoptimizer (array-in-bounds-p derive-type) ((array &rest indices))
   (assert-array-rank array (length indices))
@@ -75,7 +87,8 @@
   ;; If the node continuation has a single use then assert its type.
   (let ((cont (node-cont node)))
     (when (= (length (find-uses cont)) 1)
-      (assert-continuation-type cont (extract-element-type array))))
+      (assert-continuation-type cont (extract-upgraded-element-type array)
+                                (lexenv-policy (node-lexenv node)))))
   (extract-upgraded-element-type array))
 
 (defoptimizer (%aset derive-type) ((array &rest stuff))
     (when (array-type-p atype)
       (values-specifier-type
        `(values (simple-array ,(type-specifier
-                               (array-type-element-type atype))
+                               (array-type-specialized-element-type atype))
                              (*))
                index index index)))))
 
   (let ((simple (and (unsupplied-or-nil adjustable)
                     (unsupplied-or-nil displaced-to)
                     (unsupplied-or-nil fill-pointer))))
-    (specifier-type
-     `(,(if simple 'simple-array 'array)
-       ,(cond ((not element-type) t)
-             ((constant-continuation-p element-type)
-              (continuation-value element-type))
-             (t
-              '*))
-       ,(cond ((not simple)
-              '*)
-             ((constant-continuation-p dims)
-              (let ((val (continuation-value dims)))
-                (if (listp val) val (list val))))
-             ((csubtypep (continuation-type dims)
-                         (specifier-type 'integer))
-              '(*))
-             (t
-              '*))))))
+    (or (careful-specifier-type
+         `(,(if simple 'simple-array 'array)
+            ,(cond ((not element-type) t)
+                   ((constant-continuation-p element-type)
+                    (continuation-value element-type))
+                   (t
+                    '*))
+            ,(cond ((not simple)
+                    '*)
+                   ((constant-continuation-p dims)
+                    (let ((val (continuation-value dims)))
+                      (if (listp val) val (list val))))
+                   ((csubtypep (continuation-type dims)
+                               (specifier-type 'integer))
+                    '(*))
+                   (t
+                    '*))))
+        (specifier-type 'array))))
+
+;;; Complex array operations should assert that their array argument
+;;; is complex.  In SBCL, vectors with fill-pointers are complex.
+(defoptimizer (fill-pointer derive-type) ((vector))
+  (assert-array-complex vector))
+(defoptimizer (%set-fill-pointer derive-type) ((vector index))
+  (declare (ignorable index))
+  (assert-array-complex vector))
+
+(defoptimizer (vector-push derive-type) ((object vector))
+  (declare (ignorable object))
+  (assert-array-complex vector))
+(defoptimizer (vector-push-extend derive-type)
+    ((object vector &optional index))
+  (declare (ignorable object index))
+  (assert-array-complex vector))
+(defoptimizer (vector-pop derive-type) ((vector))
+  (assert-array-complex vector))
 \f
 ;;;; constructors
 
 ;;; Convert VECTOR into a MAKE-ARRAY followed by SETFs of all the
 ;;; elements.
-(def-source-transform vector (&rest elements)
+(define-source-transform vector (&rest elements)
   (let ((len (length elements))
        (n -1))
     (once-only ((n-vec `(make-array ,len)))
       `(progn
-        ,@(mapcar #'(lambda (el)
-                      (once-only ((n-val el))
-                        `(locally (declare (optimize (safety 0)))
-                                  (setf (svref ,n-vec ,(incf n))
-                                        ,n-val))))
+        ,@(mapcar (lambda (el)
+                    (once-only ((n-val el))
+                      `(locally (declare (optimize (safety 0)))
+                                (setf (svref ,n-vec ,(incf n))
+                                      ,n-val))))
                   elements)
         ,n-vec))))
 
 ;;; Just convert it into a MAKE-ARRAY.
-(def-source-transform make-string (length &key
-                                         (element-type ''base-char)
-                                         (initial-element
-                                          '#.*default-init-char-form*))
-  `(make-array (the index ,length)
-              :element-type ,element-type
-              :initial-element ,initial-element))
+(deftransform make-string ((length &key
+                                  (element-type 'base-char)
+                                  (initial-element
+                                   #.*default-init-char-form*)))
+  '(make-array (the index length)
+               :element-type element-type
+               :initial-element initial-element))
 
 (defstruct (specialized-array-element-type-properties
            (:conc-name saetp-)
         (destructuring-bind (type-spec &rest rest) args
           (let ((ctype (specifier-type type-spec)))
             (apply #'!make-saetp ctype rest))))
-       `((base-char ,(code-char 0) 8 ,sb!vm:simple-string-widetag
+       `(;; Erm.  Yeah.  There aren't a lot of things that make sense
+        ;; for an initial element for (ARRAY NIL). -- CSR, 2002-03-07
+        (nil '#:mu 0 ,sb!vm:simple-array-nil-widetag)
+        (base-char ,(code-char 0) 8 ,sb!vm:simple-string-widetag
                    ;; (SIMPLE-STRINGs are stored with an extra trailing
                    ;; #\NULL for convenience in calling out to C.)
                    :n-pad-elements 1)
-        (single-float 0.0s0 32 ,sb!vm:simple-array-single-float-widetag)
+        (single-float 0.0f0 32 ,sb!vm:simple-array-single-float-widetag)
         (double-float 0.0d0 64 ,sb!vm:simple-array-double-float-widetag)
         #!+long-float (long-float 0.0L0 #!+x86 96 #!+sparc 128
                                   ,sb!vm:simple-array-long-float-widetag)
         (bit 0 1 ,sb!vm:simple-bit-vector-widetag)
+        ;; KLUDGE: The fact that these UNSIGNED-BYTE entries come
+        ;; before their SIGNED-BYTE partners is significant in the
+        ;; implementation of the compiler; some of the cross-compiler
+        ;; code (see e.g. COERCE-TO-SMALLEST-ELTYPE in
+        ;; src/compiler/debug-dump.lisp) attempts to create an array
+        ;; specialized on (UNSIGNED-BYTE FOO), where FOO could be 7;
+        ;; (UNSIGNED-BYTE 7) is SUBTYPEP (SIGNED-BYTE 8), so if we're
+        ;; not careful we could get the wrong specialized array when
+        ;; we try to FIND-IF, below. -- CSR, 2002-07-08
         ((unsigned-byte 2) 0 2 ,sb!vm:simple-array-unsigned-byte-2-widetag)
         ((unsigned-byte 4) 0 4 ,sb!vm:simple-array-unsigned-byte-4-widetag)
         ((unsigned-byte 8) 0 8 ,sb!vm:simple-array-unsigned-byte-8-widetag)
         ((signed-byte 16) 0 16 ,sb!vm:simple-array-signed-byte-16-widetag)
         ((signed-byte 30) 0 32 ,sb!vm:simple-array-signed-byte-30-widetag)
         ((signed-byte 32) 0 32 ,sb!vm:simple-array-signed-byte-32-widetag)
-        ((complex single-float) #C(0.0s0 0.0s0) 64
+        ((complex single-float) #C(0.0f0 0.0f0) 64
          ,sb!vm:simple-array-complex-single-float-widetag)
         ((complex double-float) #C(0.0d0 0.0d0) 128
          ,sb!vm:simple-array-complex-double-float-widetag)
                        ,sb!vm:simple-array-complex-long-float-widetag)
         (t 0 32 ,sb!vm:simple-vector-widetag))))
 
+(deftransform make-array ((dims &key initial-element element-type
+                                    adjustable fill-pointer)
+                         (t &rest *))
+  (when (null initial-element)
+    (give-up-ir1-transform))
+  (let* ((eltype (cond ((not element-type) t)
+                      ((not (constant-continuation-p element-type))
+                       (give-up-ir1-transform
+                        "ELEMENT-TYPE is not constant."))
+                      (t
+                       (continuation-value element-type))))
+        (eltype-type (ir1-transform-specifier-type eltype))
+        (saetp (find-if (lambda (saetp)
+                          (csubtypep eltype-type (saetp-ctype saetp)))
+                        *specialized-array-element-type-properties*))
+        (creation-form `(make-array dims
+                         :element-type ',(type-specifier (saetp-ctype saetp))
+                         ,@(when fill-pointer
+                                 '(:fill-pointer fill-pointer))
+                         ,@(when adjustable
+                                 '(:adjustable adjustable)))))
+
+    (unless saetp
+      (give-up-ir1-transform "ELEMENT-TYPE not found in *SAETP*: ~S" eltype))
+
+    (cond ((and (constant-continuation-p initial-element)
+               (eql (continuation-value initial-element)
+                    (saetp-initial-element-default saetp)))
+          creation-form)
+         (t
+          ;; error checking for target, disabled on the host because
+          ;; (CTYPE-OF #\Null) is not possible.
+          #-sb-xc-host
+          (when (constant-continuation-p initial-element)
+            (let ((value (continuation-value initial-element)))
+              (cond
+                ((not (csubtypep (ctype-of value)
+                                 (saetp-ctype saetp)))
+                 ;; this case will cause an error at runtime, so we'd
+                 ;; better WARN about it now.
+                 (compiler-warn "~@<~S is not a ~S (which is the ~
+                                 UPGRADED-ARRAY-ELEMENT-TYPE of ~S).~@:>"
+                                value
+                                (type-specifier (saetp-ctype saetp))
+                                eltype))
+                ((not (csubtypep (ctype-of value) eltype-type))
+                 ;; this case will not cause an error at runtime, but
+                 ;; it's still worth STYLE-WARNing about.
+                 (compiler-style-warn "~S is not a ~S."
+                                      value eltype)))))
+          `(let ((array ,creation-form))
+            (multiple-value-bind (vector)
+                (%data-vector-and-index array 0)
+              (fill vector initial-element))
+            array)))))
+
 ;;; The integer type restriction on the length ensures that it will be
 ;;; a vector. The lack of :ADJUSTABLE, :FILL-POINTER, and
-;;; :DISPLACED-TO keywords ensures that it will be simple.
-(deftransform make-array ((length &key initial-element element-type)
+;;; :DISPLACED-TO keywords ensures that it will be simple; the lack of
+;;; :INITIAL-ELEMENT relies on another transform to deal with that
+;;; kind of initialization efficiently.
+(deftransform make-array ((length &key element-type)
                          (integer &rest *))
   (let* ((eltype (cond ((not element-type) t)
                       ((not (constant-continuation-p element-type))
                  (continuation-value length)
                  '*))
         (result-type-spec `(simple-array ,eltype (,len)))
-        (eltype-type (specifier-type eltype))
+        (eltype-type (ir1-transform-specifier-type eltype))
         (saetp (find-if (lambda (saetp)
                           (csubtypep eltype-type (saetp-ctype saetp)))
                         *specialized-array-element-type-properties*)))
     (unless saetp
       (give-up-ir1-transform
-       "cannot open-code creation of ~S" spec))
-
-    (let* ((initial-element-default (saetp-initial-element-default saetp))
-          (n-bits-per-element (saetp-n-bits saetp))
+       "cannot open-code creation of ~S" result-type-spec))
+    #-sb-xc-host
+    (unless (csubtypep (ctype-of (saetp-initial-element-default saetp))
+                      eltype-type)
+      ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE
+      ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If
+      ;; INITIAL-ELEMENT is not supplied, the consequences of later
+      ;; reading an uninitialized element of new-array are undefined,"
+      ;; so this could be legal code as long as the user plans to
+      ;; write before he reads, and if he doesn't we're free to do
+      ;; anything we like. But in case the user doesn't know to write
+      ;; elements before he reads elements (or to read manuals before
+      ;; he writes code:-), we'll signal a STYLE-WARNING in case he
+      ;; didn't realize this.
+      (compiler-style-warn "The default initial element ~S is not a ~S."
+                          (saetp-initial-element-default saetp)
+                          eltype))
+    (let* ((n-bits-per-element (saetp-n-bits saetp))
           (typecode (saetp-typecode saetp))
           (n-pad-elements (saetp-n-pad-elements saetp))
           (padded-length-form (if (zerop n-pad-elements)
                                   'length
                                   `(+ length ,n-pad-elements)))
           (n-words-form
-           (if (>= n-bits-per-element sb!vm:n-word-bits)
-               `(* ,padded-length-form
-                   (the fixnum ; i.e., not RATIO
-                     ,(/ n-bits-per-element sb!vm:n-word-bits)))
-               (let ((n-elements-per-word (/ sb!vm:n-word-bits
-                                             n-bits-per-element)))
-                 (declare (type index n-elements-per-word)) ; i.e., not RATIO
-                 `(ceiling ,padded-length-form ,n-elements-per-word))))
-          (bare-constructor-form
-           `(truly-the ,result-type-spec
-                       (allocate-vector ,typecode length ,n-words-form)))
-          (initial-element-form (if initial-element
-                                    'initial-element
-                                    initial-element-default)))
+           (cond
+             ((= n-bits-per-element 0) 0)
+             ((>= n-bits-per-element sb!vm:n-word-bits)
+              `(* ,padded-length-form
+                (the fixnum ; i.e., not RATIO
+                  ,(/ n-bits-per-element sb!vm:n-word-bits))))
+             (t
+              (let ((n-elements-per-word (/ sb!vm:n-word-bits
+                                            n-bits-per-element)))
+                (declare (type index n-elements-per-word)) ; i.e., not RATIO
+                `(ceiling ,padded-length-form ,n-elements-per-word))))))
       (values
-       (cond (;; Can we skip the FILL step?
-             (or (null initial-element)
-                 (and (constant-continuation-p initial-element)
-                      (eql (continuation-value initial-element)
-                           initial-element-default)))
-             (unless (csubtypep (ctype-of initial-element-default)
-                                eltype-type)
-               ;; This situation arises e.g. in
-               ;;   (MAKE-ARRAY 4 :ELEMENT-TYPE '(INTEGER 1 5))
-               ;; ANSI's definition of MAKE-ARRAY says "If
-               ;; INITIAL-ELEMENT is not supplied, the consequences
-               ;; of later reading an uninitialized element of
-               ;; new-array are undefined," so this could be legal
-               ;; code as long as the user plans to write before he
-               ;; reads, and if he doesn't we're free to do anything
-               ;; we like. But in case the user doesn't know to write
-               ;; elements before he reads elements (or to read
-               ;; manuals before he writes code:-), we'll signal a
-               ;; STYLE-WARNING in case he didn't realize this.
-               (compiler-note "The default initial element ~S is not a ~S."
-                              initial-element-default
-                              eltype))
-             bare-constructor-form)
-            (t
-             `(truly-the ,result-type-spec
-                         (fill ,bare-constructor-form
-                               ,initial-element-form))))
+       `(truly-the ,result-type-spec
+        (allocate-vector ,typecode length ,n-words-form))
        '((declare (type index length)))))))
 
 ;;; The list type restriction does not ensure that the result will be a
 ;;; multi-dimensional array. But the lack of adjustable, fill-pointer,
 ;;; and displaced-to keywords ensures that it will be simple.
-(deftransform make-array ((dims &key initial-element element-type)
+;;;
+;;; FIXME: should we generalize this transform to non-simple (though
+;;; non-displaced-to) arrays, given that we have %WITH-ARRAY-DATA to
+;;; deal with those? Maybe when the DEFTRANSFORM
+;;; %DATA-VECTOR-AND-INDEX in the VECTOR case problem is solved? --
+;;; CSR, 2002-07-01
+(deftransform make-array ((dims &key element-type)
                          (list &rest *))
   (unless (or (null element-type) (constant-continuation-p element-type))
     (give-up-ir1-transform
        dims))
     (if (= (length dims) 1)
        `(make-array ',(car dims)
-                    ,@(when initial-element
-                        '(:initial-element initial-element))
                     ,@(when element-type
                         '(:element-type element-type)))
        (let* ((total-size (reduce #'* dims))
             (setf (%array-data-vector header)
                   (make-array ,total-size
                               ,@(when element-type
-                                  '(:element-type element-type))
-                              ,@(when initial-element
-                                  '(:initial-element initial-element))))
+                                  '(:element-type element-type))))
             (setf (%array-displaced-p header) nil)
             ,@(let ((axis -1))
-                (mapcar #'(lambda (dim)
-                            `(setf (%array-dimension header ,(incf axis))
-                                   ,dim))
+                (mapcar (lambda (dim)
+                          `(setf (%array-dimension header ,(incf axis))
+                                 ,dim))
                         dims))
             (truly-the ,spec header))))))
 \f
        (give-up-ir1-transform
         "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime."))
       (unless (> (length dims) axis)
-       (abort-ir1-transform "The array has dimensions ~S, ~D is too large."
+       (abort-ir1-transform "The array has dimensions ~S, ~W is too large."
                             dims
                             axis))
       (let ((dim (nth axis dims)))
                  `(if (<= ,n-svalue ,n-end ,n-len)
                       ;; success
                       (values ,n-array ,n-svalue ,n-end 0)
-                      ;; failure: Make a NOTINLINE call to
-                      ;; %WITH-ARRAY-DATA with our bad data
-                      ;; to cause the error to be signalled.
-                      (locally
-                        (declare (notinline %with-array-data))
-                        (%with-array-data ,n-array ,n-svalue ,n-evalue)))))
+                      (failed-%with-array-data ,n-array
+                                               ,n-svalue
+                                               ,n-evalue))))
             (,(if force-inline '%with-array-data-macro '%with-array-data)
              ,n-array ,n-svalue ,n-evalue))
        ,@forms)))
                                   (element-type '*)
                                   unsafe?
                                   fail-inline?)
-  (let ((size (gensym "SIZE-"))
-       (defaulted-end (gensym "DEFAULTED-END-"))
-       (data (gensym "DATA-"))
-       (cumulative-offset (gensym "CUMULATIVE-OFFSET-")))
+  (with-unique-names (size defaulted-end data cumulative-offset)
     `(let* ((,size (array-total-size ,array))
            (,defaulted-end
              (cond (,end
                     (unless (or ,unsafe? (<= ,end ,size))
                       ,(if fail-inline?
-                           `(error "End ~D is greater than total size ~D."
-                                   ,end ,size)
+                           `(error 'bounding-indices-bad-error
+                             :datum (cons ,start ,end)
+                             :expected-type `(cons (integer 0 ,',size)
+                                                   (integer ,',start ,',size))
+                             :object ,array)
                            `(failed-%with-array-data ,array ,start ,end)))
                     ,end)
                    (t ,size))))
        (unless (or ,unsafe? (<= ,start ,defaulted-end))
         ,(if fail-inline?
-             `(error "Start ~D is greater than end ~D." ,start ,defaulted-end)
+             `(error 'bounding-indices-bad-error
+               :datum (cons ,start ,end)
+               :expected-type `(cons (integer 0 ,',size)
+                                     (integer ,',start ,',size))
+               :object ,array)
              `(failed-%with-array-data ,array ,start ,end)))
        (do ((,data ,array (%array-data-vector ,data))
            (,cumulative-offset 0
         (declare (type index ,cumulative-offset))))))
 
 (deftransform %with-array-data ((array start end)
-                               ;; Note: This transform is limited to
-                               ;; VECTOR only because I happened to
-                               ;; create it in order to get sequence
-                               ;; function operations to be more
-                               ;; efficient. It might very well be
-                               ;; reasonable to allow general ARRAY
-                               ;; here, I just haven't tried to
-                               ;; understand the performance issues
-                               ;; involved. -- WHN
-                               (vector index (or index null))
+                               ;; It might very well be reasonable to
+                               ;; allow general ARRAY here, I just
+                               ;; haven't tried to understand the
+                               ;; performance issues involved. --
+                               ;; WHN, and also CSR 2002-05-26
+                               ((or vector simple-array) index (or index null))
                                *
                                :important t
                                :node node
 ;;; assertions on the array.
 (macrolet ((define-frob (reffer setter type)
             `(progn
-               (def-source-transform ,reffer (a &rest i)
+               (define-source-transform ,reffer (a &rest i)
                  `(aref (the ,',type ,a) ,@i))
-               (def-source-transform ,setter (a &rest i)
+               (define-source-transform ,setter (a &rest i)
                  `(%aset (the ,',type ,a) ,@i)))))
-  (define-frob svref %svset simple-vector)
-  (define-frob schar %scharset simple-string)
-  (define-frob char %charset string)
   (define-frob sbit %sbitset (simple-array bit))
   (define-frob bit %bitset (array bit)))
+(macrolet ((define-frob (reffer setter type)
+            `(progn
+               (define-source-transform ,reffer (a i)
+                 `(aref (the ,',type ,a) ,i))
+               (define-source-transform ,setter (a i v)
+                 `(%aset (the ,',type ,a) ,i ,v)))))
+  (define-frob svref %svset simple-vector)
+  (define-frob schar %scharset simple-string)
+  (define-frob char %charset string))
 
 (macrolet (;; This is a handy macro for computing the row-major index
           ;; given a set of indices. We wrap each index with a call
 ;;;; and eliminates the need for any VM-dependent transforms to handle
 ;;;; these cases.
 
-(dolist (fun '(bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1
-                      bit-andc2 bit-orc1 bit-orc2))
-  ;; Make a result array if result is NIL or unsupplied.
-  (deftransform fun ((bit-array-1 bit-array-2 &optional result-bit-array)
-                    '(bit-vector bit-vector &optional null) '*
-                    :eval-name t
-                    :policy (>= speed space))
-    `(,fun bit-array-1 bit-array-2
-          (make-array (length bit-array-1) :element-type 'bit)))
-  ;; If result is T, make it the first arg.
-  (deftransform fun ((bit-array-1 bit-array-2 result-bit-array)
-                    '(bit-vector bit-vector (member t)) '*
-                    :eval-name t)
-    `(,fun bit-array-1 bit-array-2 bit-array-1)))
+(macrolet ((def (fun)
+             `(progn
+               (deftransform ,fun ((bit-array-1 bit-array-2
+                                               &optional result-bit-array)
+                                   (bit-vector bit-vector &optional null) *
+                                   :policy (>= speed space))
+                 `(,',fun bit-array-1 bit-array-2
+                   (make-array (length bit-array-1) :element-type 'bit)))
+               ;; If result is T, make it the first arg.
+               (deftransform ,fun ((bit-array-1 bit-array-2 result-bit-array)
+                                   (bit-vector bit-vector (member t)) *)
+                 `(,',fun bit-array-1 bit-array-2 bit-array-1)))))
+  (def bit-and)
+  (def bit-ior)
+  (def bit-xor)
+  (def bit-eqv)
+  (def bit-nand)
+  (def bit-nor)
+  (def bit-andc1)
+  (def bit-andc2)
+  (def bit-orc1)
+  (def bit-orc2))
 
 ;;; Similar for BIT-NOT, but there is only one arg...
 (deftransform bit-not ((bit-array-1 &optional result-bit-array)
   '(bit-not bit-array-1
            (make-array (length bit-array-1) :element-type 'bit)))
 (deftransform bit-not ((bit-array-1 result-bit-array)
-                      (bit-vector (constant-argument t)))
+                      (bit-vector (constant-arg t)))
   '(bit-not bit-array-1 bit-array-1))
-;;; FIXME: What does (CONSTANT-ARGUMENT T) mean? Is it the same thing
-;;; as (CONSTANT-ARGUMENT (MEMBER T)), or does it mean any constant
+;;; FIXME: What does (CONSTANT-ARG T) mean? Is it the same thing
+;;; as (CONSTANT-ARG (MEMBER T)), or does it mean any constant
 ;;; value?
 \f
 ;;; Pick off some constant cases.
 (deftransform array-header-p ((array) (array))
   (let ((type (continuation-type array)))
-    (declare (optimize (safety 3)))
     (unless (array-type-p type)
       (give-up-ir1-transform))
     (let ((dims (array-type-dimensions type)))
       (cond ((csubtypep type (specifier-type '(simple-array * (*))))
-            ;; No array header.
+            ;; no array header
             nil)
            ((and (listp dims) (> (length dims) 1))
-            ;; Multi-dimensional array, will have a header.
+            ;; multi-dimensional array, will have a header
             t)
            (t
             (give-up-ir1-transform))))))