X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=3d6448a701c94086c3312849e4741a907d30548d;hb=bfa4310e41dcd011ca9d139f29be1c5757b41378;hp=3bce54895d00dded3a42782627859a95e68fbf2d;hpb=a72b7117e8f2a832f85bf18f21dbbd8e804211ec;p=sbcl.git

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 3bce548..3d6448a 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -13,11 +13,11 @@
 
 ;;;; utilities for optimizing array operations
 
-;;; Return UPGRADED-ARRAY-ELEMENT-TYPE for CONTINUATION, or do
+;;; Return UPGRADED-ARRAY-ELEMENT-TYPE for LVAR, or do
 ;;; GIVE-UP-IR1-TRANSFORM if the upgraded element type can't be
 ;;; determined.
-(defun upgraded-element-type-specifier-or-give-up (continuation)
-  (let* ((element-ctype (extract-upgraded-element-type continuation))
+(defun upgraded-element-type-specifier-or-give-up (lvar)
+  (let* ((element-ctype (extract-upgraded-element-type lvar))
 	 (element-type-specifier (type-specifier element-ctype)))
     (if (eq element-type-specifier '*)
 	(give-up-ir1-transform
@@ -27,7 +27,7 @@
 ;;; 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)))
+  (let ((type (lvar-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),
@@ -41,43 +41,49 @@
 	;; 2002-08-21
 	*wild-type*)))
 
+(defun extract-declared-element-type (array)
+  (let ((type (lvar-type array)))
+    (if (array-type-p type)
+	(array-type-element-type type)
+	*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
 ;;; functions.
 (defun assert-new-value-type (new-value array)
-  (let ((type (continuation-type array)))
+  (let ((type (lvar-type array)))
     (when (array-type-p type)
-      (assert-continuation-type
+      (assert-lvar-type
        new-value
        (array-type-specialized-element-type type)
-       (lexenv-policy (node-lexenv (continuation-dest new-value))))))
-  (continuation-type new-value))
+       (lexenv-policy (node-lexenv (lvar-dest new-value))))))
+  (lvar-type new-value))
 
 (defun assert-array-complex (array)
-  (assert-continuation-type
+  (assert-lvar-type
    array
    (make-array-type :complexp t
                     :element-type *wild-type*)
-   (lexenv-policy (node-lexenv (continuation-dest array))))
+   (lexenv-policy (node-lexenv (lvar-dest array))))
   nil)
 
-;;; Return true if ARG is NIL, or is a constant-continuation whose
+;;; Return true if ARG is NIL, or is a constant-lvar whose
 ;;; value is NIL, false otherwise.
 (defun unsupplied-or-nil (arg)
-  (declare (type (or continuation null) arg))
+  (declare (type (or lvar null) arg))
   (or (not arg)
-      (and (constant-continuation-p arg)
-	   (not (continuation-value arg)))))
+      (and (constant-lvar-p arg)
+	   (not (lvar-value arg)))))
 
 ;;;; DERIVE-TYPE optimizers
 
 ;;; Array operations that use a specific number of indices implicitly
 ;;; assert that the array is of that rank.
 (defun assert-array-rank (array rank)
-  (assert-continuation-type
+  (assert-lvar-type
    array
    (specifier-type `(array * ,(make-list rank :initial-element '*)))
-   (lexenv-policy (node-lexenv (continuation-dest array)))))
+   (lexenv-policy (node-lexenv (lvar-dest array)))))
 
 (defoptimizer (array-in-bounds-p derive-type) ((array &rest indices))
   (assert-array-rank array (length indices))
@@ -85,11 +91,6 @@
 
 (defoptimizer (aref derive-type) ((array &rest indices) node)
   (assert-array-rank array (length indices))
-  ;; 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-upgraded-element-type array)
-                                (lexenv-policy (node-lexenv node)))))
   (extract-upgraded-element-type array))
 
 (defoptimizer (%aset derive-type) ((array &rest stuff))
@@ -109,7 +110,7 @@
 ;;; Figure out the type of the data vector if we know the argument
 ;;; element type.
 (defoptimizer (%with-array-data derive-type) ((array start end))
-  (let ((atype (continuation-type array)))
+  (let ((atype (lvar-type array)))
     (when (array-type-p atype)
       (specifier-type
        `(simple-array ,(type-specifier
@@ -135,14 +136,22 @@
     (or (careful-specifier-type
          `(,(if simple 'simple-array 'array)
             ,(cond ((not element-type) t)
-                   ((constant-continuation-p element-type)
-                    (continuation-value element-type))
+                   ((constant-lvar-p element-type)
+		    (let ((ctype (careful-specifier-type
+				  (lvar-value element-type))))
+		      (cond
+			((or (null ctype) (unknown-type-p ctype)) '*)
+			(t (sb!xc:upgraded-array-element-type
+			    (lvar-value element-type))))))
                    (t
                     '*))
-            ,(cond ((constant-continuation-p dims)
-                    (let ((val (continuation-value dims)))
-                      (if (listp val) val (list val))))
-                   ((csubtypep (continuation-type dims)
+            ,(cond ((constant-lvar-p dims)
+                    (let* ((val (lvar-value dims))
+			   (cdims (if (listp val) val (list val))))
+		      (if simple
+			  cdims
+			  (length cdims))))
+                   ((csubtypep (lvar-type dims)
                                (specifier-type 'integer))
                     '(*))
                    (t
@@ -186,83 +195,13 @@
 
 ;;; Just convert it into a MAKE-ARRAY.
 (deftransform make-string ((length &key
-				   (element-type 'base-char)
+				   (element-type 'character)
 				   (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-)
-	    (:constructor !make-saetp (ctype
-				       initial-element-default
-				       n-bits
-				       typecode
-				       &key
-				       (n-pad-elements 0)))
-	    (:copier nil))
-  ;; the element type, e.g. #<BUILT-IN-CLASS BASE-CHAR (sealed)> or
-  ;; #<SB-KERNEL:NUMERIC-TYPE (UNSIGNED-BYTE 4)>
-  (ctype (missing-arg) :type ctype :read-only t)
-  ;; what we get when the low-level vector-creation logic zeroes all
-  ;; the bits (which also serves as the default value of MAKE-ARRAY's
-  ;; :INITIAL-ELEMENT keyword)
-  (initial-element-default (missing-arg) :read-only t)
-  ;; how many bits per element
-  (n-bits (missing-arg) :type index :read-only t)
-  ;; the low-level type code
-  (typecode (missing-arg) :type index :read-only t)
-  ;; the number of extra elements we use at the end of the array for
-  ;; low level hackery (e.g., one element for arrays of BASE-CHAR,
-  ;; which is used for a fixed #\NULL so that when we call out to C
-  ;; we don't need to cons a new copy)
-  (n-pad-elements (missing-arg) :type index :read-only t))
-
-(defparameter *specialized-array-element-type-properties*
-  (map 'simple-vector
-       (lambda (args)
-	 (destructuring-bind (type-spec &rest rest) args
-	   (let ((ctype (specifier-type type-spec)))
-	     (apply #'!make-saetp ctype rest))))
-       `(;; 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.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)
-	 ((unsigned-byte 16) 0 16 ,sb!vm:simple-array-unsigned-byte-16-widetag)
-	 ((unsigned-byte 32) 0 32 ,sb!vm:simple-array-unsigned-byte-32-widetag)
-	 ((signed-byte 8) 0 8 ,sb!vm:simple-array-signed-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.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)
-	 #!+long-float ((complex long-float) #C(0.0L0 0.0L0)
-			#!+x86 192 #!+sparc 256
-			,sb!vm:simple-array-complex-long-float-widetag)
-	 (t 0 32 ,sb!vm:simple-vector-widetag))))
+  `(the simple-string (make-array (the index length)
+		       :element-type element-type
+		       ,@(when initial-element
+			   '(:initial-element initial-element)))))
 
 (deftransform make-array ((dims &key initial-element element-type
 				     adjustable fill-pointer)
@@ -270,17 +209,17 @@
   (when (null initial-element)
     (give-up-ir1-transform))
   (let* ((eltype (cond ((not element-type) t)
-		       ((not (constant-continuation-p element-type))
+		       ((not (constant-lvar-p element-type))
 			(give-up-ir1-transform
 			 "ELEMENT-TYPE is not constant."))
 		       (t
-			(continuation-value element-type))))
+			(lvar-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*))
+			   (csubtypep eltype-type (sb!vm:saetp-ctype saetp)))
+			 sb!vm:*specialized-array-element-type-properties*))
 	 (creation-form `(make-array dims
-			  :element-type ',(type-specifier (saetp-ctype saetp))
+			  :element-type ',(type-specifier (sb!vm:saetp-ctype saetp))
 			  ,@(when fill-pointer
 				  '(:fill-pointer fill-pointer))
 			  ,@(when adjustable
@@ -289,25 +228,29 @@
     (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)))
+    (cond ((and (constant-lvar-p initial-element)
+		(eql (lvar-value initial-element)
+		     (sb!vm: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)))
+	   (when (constant-lvar-p initial-element)
+	     (let ((value (lvar-value initial-element)))
 	       (cond
-		 ((not (ctypep value (saetp-ctype saetp)))
+		 ((not (ctypep value (sb!vm: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))
+		  (warn 'array-initial-element-mismatch
+			:format-control "~@<~S is not a ~S (which is the ~
+                                         ~S of ~S).~@:>"
+			:format-arguments 
+			(list 
+			 value
+			 (type-specifier (sb!vm:saetp-ctype saetp))
+			 'upgraded-array-element-type
+			 eltype)))
 		 ((not (ctypep value eltype-type))
 		  ;; this case will not cause an error at runtime, but
 		  ;; it's still worth STYLE-WARNing about.
@@ -327,24 +270,30 @@
 (deftransform make-array ((length &key element-type)
 			  (integer &rest *))
   (let* ((eltype (cond ((not element-type) t)
-		       ((not (constant-continuation-p element-type))
+		       ((not (constant-lvar-p element-type))
 			(give-up-ir1-transform
 			 "ELEMENT-TYPE is not constant."))
 		       (t
-			(continuation-value element-type))))
-	 (len (if (constant-continuation-p length)
-		  (continuation-value length)
+			(lvar-value element-type))))
+	 (len (if (constant-lvar-p length)
+		  (lvar-value length)
 		  '*))
-	 (result-type-spec `(simple-array ,eltype (,len)))
 	 (eltype-type (ir1-transform-specifier-type eltype))
+	 (result-type-spec
+	  `(simple-array
+	    ,(if (unknown-type-p eltype-type)
+		 (give-up-ir1-transform
+		  "ELEMENT-TYPE is an unknown type: ~S" eltype)
+		 (sb!xc:upgraded-array-element-type eltype))
+	    (,len)))
 	 (saetp (find-if (lambda (saetp)
-			   (csubtypep eltype-type (saetp-ctype saetp)))
-			 *specialized-array-element-type-properties*)))
+			   (csubtypep eltype-type (sb!vm:saetp-ctype saetp)))
+			 sb!vm:*specialized-array-element-type-properties*)))
     (unless saetp
       (give-up-ir1-transform
        "cannot open-code creation of ~S" result-type-spec))
     #-sb-xc-host
-    (unless (csubtypep (ctype-of (saetp-initial-element-default saetp))
+    (unless (csubtypep (ctype-of (sb!vm: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
@@ -357,11 +306,11 @@
       ;; 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)
+			   (sb!vm: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))
+    (let* ((n-bits-per-element (sb!vm:saetp-n-bits saetp))
+	   (typecode (sb!vm:saetp-typecode saetp))
+	   (n-pad-elements (sb!vm:saetp-n-pad-elements saetp))
 	   (padded-length-form (if (zerop n-pad-elements)
 				   'length
 				   `(+ length ,n-pad-elements)))
@@ -393,13 +342,13 @@
 ;;; CSR, 2002-07-01
 (deftransform make-array ((dims &key element-type)
 			  (list &rest *))
-  (unless (or (null element-type) (constant-continuation-p element-type))
+  (unless (or (null element-type) (constant-lvar-p element-type))
     (give-up-ir1-transform
      "The element-type is not constant; cannot open code array creation."))
-  (unless (constant-continuation-p dims)
+  (unless (constant-lvar-p dims)
     (give-up-ir1-transform
      "The dimension list is not constant; cannot open code array creation."))
-  (let ((dims (continuation-value dims)))
+  (let ((dims (lvar-value dims)))
     (unless (every #'integerp dims)
       (give-up-ir1-transform
        "The dimension list contains something other than an integer: ~S"
@@ -412,8 +361,11 @@
 	       (rank (length dims))
 	       (spec `(simple-array
 		       ,(cond ((null element-type) t)
-			      ((constant-continuation-p element-type)
-			       (continuation-value element-type))
+			      ((and (constant-lvar-p element-type)
+				    (ir1-transform-specifier-type
+				     (lvar-value element-type)))
+			       (sb!xc:upgraded-array-element-type
+				(lvar-value element-type)))
 			      (t '*))
 			   ,(make-list rank :initial-element '*))))
 	  `(let ((header (make-array-header sb!vm:simple-array-widetag ,rank)))
@@ -437,12 +389,41 @@
 ;;; Transforms for various array properties. If the property is know
 ;;; at compile time because of a type spec, use that constant value.
 
+;;; Most of this logic may end up belonging in code/late-type.lisp;
+;;; however, here we also need the -OR-GIVE-UP for the transforms, and
+;;; maybe this is just too sloppy for actual type logic.  -- CSR,
+;;; 2004-02-18
+(defun array-type-dimensions-or-give-up (type)
+  (typecase type
+    (array-type (array-type-dimensions type))
+    (union-type
+     (let ((types (union-type-types type)))
+       ;; there are at least two types, right?
+       (aver (> (length types) 1))
+       (let ((result (array-type-dimensions-or-give-up (car types))))
+	 (dolist (type (cdr types) result)
+	   (unless (equal (array-type-dimensions-or-give-up type) result)
+	     (give-up-ir1-transform))))))
+    ;; FIXME: intersection type [e.g. (and (array * (*)) (satisfies foo)) ]
+    (t (give-up-ir1-transform))))
+
+(defun conservative-array-type-complexp (type)
+  (typecase type
+    (array-type (array-type-complexp type))
+    (union-type
+     (let ((types (union-type-types type)))
+       (aver (> (length types) 1))
+       (let ((result (conservative-array-type-complexp (car types))))
+	 (dolist (type (cdr types) result)
+	   (unless (eq (conservative-array-type-complexp type) result)
+	     (return-from conservative-array-type-complexp :maybe))))))
+    ;; FIXME: intersection type
+    (t :maybe)))
+
 ;;; If we can tell the rank from the type info, use it instead.
 (deftransform array-rank ((array))
-  (let ((array-type (continuation-type array)))
-    (unless (array-type-p array-type)
-      (give-up-ir1-transform))
-    (let ((dims (array-type-dimensions array-type)))
+  (let ((array-type (lvar-type array)))
+    (let ((dims (array-type-dimensions-or-give-up array-type)))
       (if (not (listp dims))
 	  (give-up-ir1-transform
 	   "The array rank is not known at compile time: ~S"
@@ -455,13 +436,11 @@
 ;;; (if it's simple and a vector).
 (deftransform array-dimension ((array axis)
 			       (array index))
-  (unless (constant-continuation-p axis)
+  (unless (constant-lvar-p axis)
     (give-up-ir1-transform "The axis is not constant."))
-  (let ((array-type (continuation-type array))
-	(axis (continuation-value axis)))
-    (unless (array-type-p array-type)
-      (give-up-ir1-transform))
-    (let ((dims (array-type-dimensions array-type)))
+  (let ((array-type (lvar-type array))
+	(axis (lvar-value axis)))
+    (let ((dims (array-type-dimensions-or-give-up array-type)))
       (unless (listp dims)
 	(give-up-ir1-transform
 	 "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime."))
@@ -473,7 +452,7 @@
 	(cond ((integerp dim)
 	       dim)
 	      ((= (length dims) 1)
-	       (ecase (array-type-complexp array-type)
+	       (ecase (conservative-array-type-complexp array-type)
 		 ((t)
 		  '(%array-dimension array 0))
 		 ((nil)
@@ -487,10 +466,8 @@
 ;;; If the length has been declared and it's simple, just return it.
 (deftransform length ((vector)
 		      ((simple-array * (*))))
-  (let ((type (continuation-type vector)))
-    (unless (array-type-p type)
-      (give-up-ir1-transform))
-    (let ((dims (array-type-dimensions type)))
+  (let ((type (lvar-type vector)))
+    (let ((dims (array-type-dimensions-or-give-up type)))
       (unless (and (listp dims) (integerp (car dims)))
 	(give-up-ir1-transform
 	 "Vector length is unknown, must call LENGTH at runtime."))
@@ -506,13 +483,13 @@
 ;;; If a simple array with known dimensions, then VECTOR-LENGTH is a
 ;;; compile-time constant.
 (deftransform vector-length ((vector))
-  (let ((vtype (continuation-type vector)))
-    (if (and (array-type-p vtype)
-	     (not (array-type-complexp vtype)))
-	(let ((dim (first (array-type-dimensions vtype))))
-	  (when (eq dim '*) (give-up-ir1-transform))
-	  dim)
-	(give-up-ir1-transform))))
+  (let ((vtype (lvar-type vector)))
+    (let ((dim (first (array-type-dimensions-or-give-up vtype))))
+      (when (eq dim '*)
+	(give-up-ir1-transform))
+      (when (conservative-array-type-complexp vtype)
+	(give-up-ir1-transform))
+      dim)))
 
 ;;; Again, if we can tell the results from the type, just use it.
 ;;; Otherwise, if we know the rank, convert into a computation based
@@ -521,10 +498,8 @@
 ;;; INDEX.
 (deftransform array-total-size ((array)
 				(array))
-  (let ((array-type (continuation-type array)))
-    (unless (array-type-p array-type)
-      (give-up-ir1-transform))
-    (let ((dims (array-type-dimensions array-type)))
+  (let ((array-type (lvar-type array)))
+    (let ((dims (array-type-dimensions-or-give-up array-type)))
       (unless (listp dims)
 	(give-up-ir1-transform "can't tell the rank at compile time"))
       (if (member '* dims)
@@ -536,13 +511,11 @@
 
 ;;; Only complex vectors have fill pointers.
 (deftransform array-has-fill-pointer-p ((array))
-  (let ((array-type (continuation-type array)))
-    (unless (array-type-p array-type)
-      (give-up-ir1-transform))
-    (let ((dims (array-type-dimensions array-type)))
+  (let ((array-type (lvar-type array)))
+    (let ((dims (array-type-dimensions-or-give-up array-type)))
       (if (and (listp dims) (not (= (length dims) 1)))
 	  nil
-	  (ecase (array-type-complexp array-type)
+	  (ecase (conservative-array-type-complexp array-type)
 	    ((t)
 	     t)
 	    ((nil)
@@ -555,14 +528,14 @@
 ;;; Primitive used to verify indices into arrays. If we can tell at
 ;;; compile-time or we are generating unsafe code, don't bother with
 ;;; the VOP.
-(deftransform %check-bound ((array dimension index))
-  (unless (constant-continuation-p dimension)
-    (give-up-ir1-transform))
-  (let ((dim (continuation-value dimension)))
-    `(the (integer 0 ,dim) index)))
-(deftransform %check-bound ((array dimension index) * *
-			    :policy (and (> speed safety) (= safety 0)))
-  'index)
+(deftransform %check-bound ((array dimension index) * * :node node)
+  (cond ((policy node (and (> speed safety) (= safety 0)))
+         'index)
+        ((not (constant-lvar-p dimension))
+         (give-up-ir1-transform))
+        (t
+         (let ((dim (lvar-value dimension)))
+           `(the (integer 0 (,dim)) index)))))
 
 ;;;; WITH-ARRAY-DATA
 
@@ -783,7 +756,7 @@
                    (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)) *)
+                                   (bit-vector bit-vector (eql t)) *)
                  `(,',fun bit-array-1 bit-array-2 bit-array-1)))))
   (def bit-and)
   (def bit-ior)
@@ -803,23 +776,22 @@
   '(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-arg t)))
+		       (bit-vector (eql t)))
   '(bit-not bit-array-1 bit-array-1))
-;;; FIXME: What does (CONSTANT-ARG T) mean? Is it the same thing
-;;; as (CONSTANT-ARG (MEMBER T)), or does it mean any constant
-;;; value?
 
 ;;; Pick off some constant cases.
-(deftransform array-header-p ((array) (array))
-  (let ((type (continuation-type array)))
-    (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
-	     nil)
-	    ((and (listp dims) (/= (length dims) 1))
-	     ;; multi-dimensional array, will have a header
-	     t)
-	    (t
-	     (give-up-ir1-transform))))))
+(defoptimizer (array-header-p derive-type) ((array))
+  (let ((type (lvar-type array)))
+    (cond ((not (array-type-p type))
+	   ;; FIXME: use analogue of ARRAY-TYPE-DIMENSIONS-OR-GIVE-UP
+           nil)
+          (t
+           (let ((dims (array-type-dimensions type)))
+             (cond ((csubtypep type (specifier-type '(simple-array * (*))))
+                    ;; no array header
+                    (specifier-type 'null))
+                   ((and (listp dims) (/= (length dims) 1))
+                    ;; multi-dimensional array, will have a header
+                    (specifier-type '(eql t)))
+                   (t
+                    nil)))))))