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