1.0.21.14: fix CHECK-FASL-HEADER buglet
[sbcl.git] / src / compiler / array-tran.lisp
1 ;;;; array-specific optimizers and transforms
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!C")
13 \f
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-ctype (extract-upgraded-element-type lvar))
21          (element-type-specifier (type-specifier element-ctype)))
22     (if (eq element-type-specifier '*)
23         (give-up-ir1-transform
24          "upgraded array element type not known at compile time")
25         element-type-specifier)))
26
27 ;;; Array access functions return an object from the array, hence its type is
28 ;;; going to be the array upgraded element type. Secondary return value is the
29 ;;; known supertype of the upgraded-array-element-type, if if the exact
30 ;;; U-A-E-T is not known. (If it is NIL, the primary return value is as good
31 ;;; as it gets.)
32 (defun extract-upgraded-element-type (array)
33   (let ((type (lvar-type array)))
34     (cond
35       ;; Note that this IF mightn't be satisfied even if the runtime
36       ;; value is known to be a subtype of some specialized ARRAY, because
37       ;; we can have values declared e.g. (AND SIMPLE-VECTOR UNKNOWN-TYPE),
38       ;; which are represented in the compiler as INTERSECTION-TYPE, not
39       ;; array type.
40       ((array-type-p type)
41        (values (array-type-specialized-element-type type) nil))
42       ;; fix for bug #396. This type logic corresponds to the special case for
43       ;; strings in HAIRY-DATA-VECTOR-REF (generic/vm-tran.lisp)
44       ((csubtypep type (specifier-type 'string))
45        (cond
46          ((csubtypep type (specifier-type '(array character (*))))
47           (values (specifier-type 'character) nil))
48          #!+sb-unicode
49          ((csubtypep type (specifier-type '(array base-char (*))))
50           (values (specifier-type 'base-char) nil))
51          ((csubtypep type (specifier-type '(array nil (*))))
52           (values *empty-type* nil))
53          (t
54           ;; See KLUDGE below.
55           (values *wild-type* (specifier-type 'character)))))
56       (t
57        ;; KLUDGE: there is no good answer here, but at least
58        ;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be
59        ;; erroneously optimized (see generic/vm-tran.lisp) -- CSR,
60        ;; 2002-08-21
61        (values *wild-type* nil)))))
62
63 (defun extract-declared-element-type (array)
64   (let ((type (lvar-type array)))
65     (if (array-type-p type)
66         (array-type-element-type type)
67         *wild-type*)))
68
69 ;;; The ``new-value'' for array setters must fit in the array, and the
70 ;;; return type is going to be the same as the new-value for SETF
71 ;;; functions.
72 (defun assert-new-value-type (new-value array)
73   (let ((type (lvar-type array)))
74     (when (array-type-p type)
75       (assert-lvar-type
76        new-value
77        (array-type-specialized-element-type type)
78        (lexenv-policy (node-lexenv (lvar-dest new-value))))))
79   (lvar-type new-value))
80
81 (defun assert-array-complex (array)
82   (assert-lvar-type
83    array
84    (make-array-type :complexp t
85                     :element-type *wild-type*)
86    (lexenv-policy (node-lexenv (lvar-dest array))))
87   nil)
88
89 ;;; Return true if ARG is NIL, or is a constant-lvar whose
90 ;;; value is NIL, false otherwise.
91 (defun unsupplied-or-nil (arg)
92   (declare (type (or lvar null) arg))
93   (or (not arg)
94       (and (constant-lvar-p arg)
95            (not (lvar-value arg)))))
96 \f
97 ;;;; DERIVE-TYPE optimizers
98
99 ;;; Array operations that use a specific number of indices implicitly
100 ;;; assert that the array is of that rank.
101 (defun assert-array-rank (array rank)
102   (assert-lvar-type
103    array
104    (specifier-type `(array * ,(make-list rank :initial-element '*)))
105    (lexenv-policy (node-lexenv (lvar-dest array)))))
106
107 (defun derive-aref-type (array)
108   (multiple-value-bind (uaet other) (extract-upgraded-element-type array)
109     (or other uaet)))
110
111 (defoptimizer (array-in-bounds-p derive-type) ((array &rest indices))
112   (assert-array-rank array (length indices))
113   *universal-type*)
114
115 (defoptimizer (aref derive-type) ((array &rest indices) node)
116   (assert-array-rank array (length indices))
117   (derive-aref-type array))
118
119 (defoptimizer (%aset derive-type) ((array &rest stuff))
120   (assert-array-rank array (1- (length stuff)))
121   (assert-new-value-type (car (last stuff)) array))
122
123 (macrolet ((define (name)
124              `(defoptimizer (,name derive-type) ((array index))
125                 (derive-aref-type array))))
126   (define hairy-data-vector-ref)
127   (define hairy-data-vector-ref/check-bounds)
128   (define data-vector-ref))
129
130 #!+(or x86 x86-64)
131 (defoptimizer (data-vector-ref-with-offset derive-type) ((array index offset))
132   (derive-aref-type array))
133
134 (macrolet ((define (name)
135              `(defoptimizer (,name derive-type) ((array index new-value))
136                 (assert-new-value-type new-value array))))
137   (define hairy-data-vector-set)
138   (define hairy-data-vector-set/check-bounds)
139   (define data-vector-set))
140
141 #!+(or x86 x86-64)
142 (defoptimizer (data-vector-set-with-offset derive-type) ((array index offset new-value))
143   (assert-new-value-type new-value array))
144
145 ;;; Figure out the type of the data vector if we know the argument
146 ;;; element type.
147 (defun derive-%with-array-data/mumble-type (array)
148   (let ((atype (lvar-type array)))
149     (when (array-type-p atype)
150       (specifier-type
151        `(simple-array ,(type-specifier
152                         (array-type-specialized-element-type atype))
153                       (*))))))
154 (defoptimizer (%with-array-data derive-type) ((array start end))
155   (derive-%with-array-data/mumble-type array))
156 (defoptimizer (%with-array-data/fp derive-type) ((array start end))
157   (derive-%with-array-data/mumble-type array))
158
159 (defoptimizer (array-row-major-index derive-type) ((array &rest indices))
160   (assert-array-rank array (length indices))
161   *universal-type*)
162
163 (defoptimizer (row-major-aref derive-type) ((array index))
164   (derive-aref-type array))
165
166 (defoptimizer (%set-row-major-aref derive-type) ((array index new-value))
167   (assert-new-value-type new-value array))
168
169 (defoptimizer (make-array derive-type)
170               ((dims &key initial-element element-type initial-contents
171                 adjustable fill-pointer displaced-index-offset displaced-to))
172   (let ((simple (and (unsupplied-or-nil adjustable)
173                      (unsupplied-or-nil displaced-to)
174                      (unsupplied-or-nil fill-pointer))))
175     (or (careful-specifier-type
176          `(,(if simple 'simple-array 'array)
177             ,(cond ((not element-type) t)
178                    ((constant-lvar-p element-type)
179                     (let ((ctype (careful-specifier-type
180                                   (lvar-value element-type))))
181                       (cond
182                         ((or (null ctype) (unknown-type-p ctype)) '*)
183                         (t (sb!xc:upgraded-array-element-type
184                             (lvar-value element-type))))))
185                    (t
186                     '*))
187             ,(cond ((constant-lvar-p dims)
188                     (let* ((val (lvar-value dims))
189                            (cdims (if (listp val) val (list val))))
190                       (if simple
191                           cdims
192                           (length cdims))))
193                    ((csubtypep (lvar-type dims)
194                                (specifier-type 'integer))
195                     '(*))
196                    (t
197                     '*))))
198         (specifier-type 'array))))
199
200 ;;; Complex array operations should assert that their array argument
201 ;;; is complex.  In SBCL, vectors with fill-pointers are complex.
202 (defoptimizer (fill-pointer derive-type) ((vector))
203   (assert-array-complex vector))
204 (defoptimizer (%set-fill-pointer derive-type) ((vector index))
205   (declare (ignorable index))
206   (assert-array-complex vector))
207
208 (defoptimizer (vector-push derive-type) ((object vector))
209   (declare (ignorable object))
210   (assert-array-complex vector))
211 (defoptimizer (vector-push-extend derive-type)
212     ((object vector &optional index))
213   (declare (ignorable object index))
214   (assert-array-complex vector))
215 (defoptimizer (vector-pop derive-type) ((vector))
216   (assert-array-complex vector))
217 \f
218 ;;;; constructors
219
220 ;;; Convert VECTOR into a MAKE-ARRAY followed by SETFs of all the
221 ;;; elements.
222 (define-source-transform vector (&rest elements)
223   (let ((len (length elements))
224         (n -1))
225     (once-only ((n-vec `(make-array ,len)))
226       `(progn
227          ,@(mapcar (lambda (el)
228                      (once-only ((n-val el))
229                        `(locally (declare (optimize (safety 0)))
230                           (setf (svref ,n-vec ,(incf n)) ,n-val))))
231                    elements)
232          ,n-vec))))
233
234 ;;; Just convert it into a MAKE-ARRAY.
235 (deftransform make-string ((length &key
236                                    (element-type 'character)
237                                    (initial-element
238                                     #.*default-init-char-form*)))
239   `(the simple-string (make-array (the index length)
240                        :element-type element-type
241                        ,@(when initial-element
242                            '(:initial-element initial-element)))))
243
244 (deftransform make-array ((dims &key initial-element element-type
245                                      adjustable fill-pointer)
246                           (t &rest *))
247   (when (null initial-element)
248     (give-up-ir1-transform))
249   (let* ((eltype (cond ((not element-type) t)
250                        ((not (constant-lvar-p element-type))
251                         (give-up-ir1-transform
252                          "ELEMENT-TYPE is not constant."))
253                        (t
254                         (lvar-value element-type))))
255          (eltype-type (ir1-transform-specifier-type eltype))
256          (saetp (find-if (lambda (saetp)
257                            (csubtypep eltype-type (sb!vm:saetp-ctype saetp)))
258                          sb!vm:*specialized-array-element-type-properties*))
259          (creation-form `(make-array dims
260                           :element-type ',(type-specifier (sb!vm:saetp-ctype saetp))
261                           ,@(when fill-pointer
262                                   '(:fill-pointer fill-pointer))
263                           ,@(when adjustable
264                                   '(:adjustable adjustable)))))
265
266     (unless saetp
267       (give-up-ir1-transform "ELEMENT-TYPE not found in *SAETP*: ~S" eltype))
268
269     (cond ((and (constant-lvar-p initial-element)
270                 (eql (lvar-value initial-element)
271                      (sb!vm:saetp-initial-element-default saetp)))
272            creation-form)
273           (t
274            ;; error checking for target, disabled on the host because
275            ;; (CTYPE-OF #\Null) is not possible.
276            #-sb-xc-host
277            (when (constant-lvar-p initial-element)
278              (let ((value (lvar-value initial-element)))
279                (cond
280                  ((not (ctypep value (sb!vm:saetp-ctype saetp)))
281                   ;; this case will cause an error at runtime, so we'd
282                   ;; better WARN about it now.
283                   (warn 'array-initial-element-mismatch
284                         :format-control "~@<~S is not a ~S (which is the ~
285                                          ~S of ~S).~@:>"
286                         :format-arguments
287                         (list
288                          value
289                          (type-specifier (sb!vm:saetp-ctype saetp))
290                          'upgraded-array-element-type
291                          eltype)))
292                  ((not (ctypep value eltype-type))
293                   ;; this case will not cause an error at runtime, but
294                   ;; it's still worth STYLE-WARNing about.
295                   (compiler-style-warn "~S is not a ~S."
296                                        value eltype)))))
297            `(let ((array ,creation-form))
298              (multiple-value-bind (vector)
299                  (%data-vector-and-index array 0)
300                (fill vector initial-element))
301              array)))))
302
303 ;;; The integer type restriction on the length ensures that it will be
304 ;;; a vector. The lack of :ADJUSTABLE, :FILL-POINTER, and
305 ;;; :DISPLACED-TO keywords ensures that it will be simple; the lack of
306 ;;; :INITIAL-ELEMENT relies on another transform to deal with that
307 ;;; kind of initialization efficiently.
308 (deftransform make-array ((length &key element-type)
309                           (integer &rest *))
310   (let* ((eltype (cond ((not element-type) t)
311                        ((not (constant-lvar-p element-type))
312                         (give-up-ir1-transform
313                          "ELEMENT-TYPE is not constant."))
314                        (t
315                         (lvar-value element-type))))
316          (len (if (constant-lvar-p length)
317                   (lvar-value length)
318                   '*))
319          (eltype-type (ir1-transform-specifier-type eltype))
320          (result-type-spec
321           `(simple-array
322             ,(if (unknown-type-p eltype-type)
323                  (give-up-ir1-transform
324                   "ELEMENT-TYPE is an unknown type: ~S" eltype)
325                  (sb!xc:upgraded-array-element-type eltype))
326             (,len)))
327          (saetp (find-if (lambda (saetp)
328                            (csubtypep eltype-type (sb!vm:saetp-ctype saetp)))
329                          sb!vm:*specialized-array-element-type-properties*)))
330     (unless saetp
331       (give-up-ir1-transform
332        "cannot open-code creation of ~S" result-type-spec))
333     #-sb-xc-host
334     (unless (ctypep (sb!vm:saetp-initial-element-default saetp) eltype-type)
335       ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE
336       ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If
337       ;; INITIAL-ELEMENT is not supplied, the consequences of later
338       ;; reading an uninitialized element of new-array are undefined,"
339       ;; so this could be legal code as long as the user plans to
340       ;; write before he reads, and if he doesn't we're free to do
341       ;; anything we like. But in case the user doesn't know to write
342       ;; elements before he reads elements (or to read manuals before
343       ;; he writes code:-), we'll signal a STYLE-WARNING in case he
344       ;; didn't realize this.
345       (compiler-style-warn "The default initial element ~S is not a ~S."
346                            (sb!vm:saetp-initial-element-default saetp)
347                            eltype))
348     (let* ((n-bits-per-element (sb!vm:saetp-n-bits saetp))
349            (typecode (sb!vm:saetp-typecode saetp))
350            (n-pad-elements (sb!vm:saetp-n-pad-elements saetp))
351            (padded-length-form (if (zerop n-pad-elements)
352                                    'length
353                                    `(+ length ,n-pad-elements)))
354            (n-words-form
355             (cond
356               ((= n-bits-per-element 0) 0)
357               ((>= n-bits-per-element sb!vm:n-word-bits)
358                `(* ,padded-length-form
359                  (the fixnum ; i.e., not RATIO
360                    ,(/ n-bits-per-element sb!vm:n-word-bits))))
361               (t
362                (let ((n-elements-per-word (/ sb!vm:n-word-bits
363                                              n-bits-per-element)))
364                  (declare (type index n-elements-per-word)) ; i.e., not RATIO
365                  `(ceiling ,padded-length-form ,n-elements-per-word))))))
366       (values
367        `(truly-the ,result-type-spec
368          (allocate-vector ,typecode length ,n-words-form))
369        '((declare (type index length)))))))
370
371 ;;; The list type restriction does not ensure that the result will be a
372 ;;; multi-dimensional array. But the lack of adjustable, fill-pointer,
373 ;;; and displaced-to keywords ensures that it will be simple.
374 ;;;
375 ;;; FIXME: should we generalize this transform to non-simple (though
376 ;;; non-displaced-to) arrays, given that we have %WITH-ARRAY-DATA to
377 ;;; deal with those? Maybe when the DEFTRANSFORM
378 ;;; %DATA-VECTOR-AND-INDEX in the VECTOR case problem is solved? --
379 ;;; CSR, 2002-07-01
380 (deftransform make-array ((dims &key element-type)
381                           (list &rest *))
382   (unless (or (null element-type) (constant-lvar-p element-type))
383     (give-up-ir1-transform
384      "The element-type is not constant; cannot open code array creation."))
385   (unless (constant-lvar-p dims)
386     (give-up-ir1-transform
387      "The dimension list is not constant; cannot open code array creation."))
388   (let ((dims (lvar-value dims)))
389     (unless (every #'integerp dims)
390       (give-up-ir1-transform
391        "The dimension list contains something other than an integer: ~S"
392        dims))
393     (if (= (length dims) 1)
394         `(make-array ',(car dims)
395                      ,@(when element-type
396                          '(:element-type element-type)))
397         (let* ((total-size (reduce #'* dims))
398                (rank (length dims))
399                (spec `(simple-array
400                        ,(cond ((null element-type) t)
401                               ((and (constant-lvar-p element-type)
402                                     (ir1-transform-specifier-type
403                                      (lvar-value element-type)))
404                                (sb!xc:upgraded-array-element-type
405                                 (lvar-value element-type)))
406                               (t '*))
407                            ,(make-list rank :initial-element '*))))
408           `(let ((header (make-array-header sb!vm:simple-array-widetag ,rank)))
409              (setf (%array-fill-pointer header) ,total-size)
410              (setf (%array-fill-pointer-p header) nil)
411              (setf (%array-available-elements header) ,total-size)
412              (setf (%array-data-vector header)
413                    (make-array ,total-size
414                                ,@(when element-type
415                                    '(:element-type element-type))))
416              (setf (%array-displaced-p header) nil)
417              ,@(let ((axis -1))
418                  (mapcar (lambda (dim)
419                            `(setf (%array-dimension header ,(incf axis))
420                                   ,dim))
421                          dims))
422              (truly-the ,spec header))))))
423 \f
424 ;;;; miscellaneous properties of arrays
425
426 ;;; Transforms for various array properties. If the property is know
427 ;;; at compile time because of a type spec, use that constant value.
428
429 ;;; Most of this logic may end up belonging in code/late-type.lisp;
430 ;;; however, here we also need the -OR-GIVE-UP for the transforms, and
431 ;;; maybe this is just too sloppy for actual type logic.  -- CSR,
432 ;;; 2004-02-18
433 (defun array-type-dimensions-or-give-up (type)
434   (typecase type
435     (array-type (array-type-dimensions type))
436     (union-type
437      (let ((types (union-type-types type)))
438        ;; there are at least two types, right?
439        (aver (> (length types) 1))
440        (let ((result (array-type-dimensions-or-give-up (car types))))
441          (dolist (type (cdr types) result)
442            (unless (equal (array-type-dimensions-or-give-up type) result)
443              (give-up-ir1-transform))))))
444     ;; FIXME: intersection type [e.g. (and (array * (*)) (satisfies foo)) ]
445     (t (give-up-ir1-transform))))
446
447 (defun conservative-array-type-complexp (type)
448   (typecase type
449     (array-type (array-type-complexp type))
450     (union-type
451      (let ((types (union-type-types type)))
452        (aver (> (length types) 1))
453        (let ((result (conservative-array-type-complexp (car types))))
454          (dolist (type (cdr types) result)
455            (unless (eq (conservative-array-type-complexp type) result)
456              (return-from conservative-array-type-complexp :maybe))))))
457     ;; FIXME: intersection type
458     (t :maybe)))
459
460 ;;; If we can tell the rank from the type info, use it instead.
461 (deftransform array-rank ((array))
462   (let ((array-type (lvar-type array)))
463     (let ((dims (array-type-dimensions-or-give-up array-type)))
464       (if (not (listp dims))
465           (give-up-ir1-transform
466            "The array rank is not known at compile time: ~S"
467            dims)
468           (length dims)))))
469
470 ;;; If we know the dimensions at compile time, just use it. Otherwise,
471 ;;; if we can tell that the axis is in bounds, convert to
472 ;;; %ARRAY-DIMENSION (which just indirects the array header) or length
473 ;;; (if it's simple and a vector).
474 (deftransform array-dimension ((array axis)
475                                (array index))
476   (unless (constant-lvar-p axis)
477     (give-up-ir1-transform "The axis is not constant."))
478   (let ((array-type (lvar-type array))
479         (axis (lvar-value axis)))
480     (let ((dims (array-type-dimensions-or-give-up array-type)))
481       (unless (listp dims)
482         (give-up-ir1-transform
483          "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime."))
484       (unless (> (length dims) axis)
485         (abort-ir1-transform "The array has dimensions ~S, ~W is too large."
486                              dims
487                              axis))
488       (let ((dim (nth axis dims)))
489         (cond ((integerp dim)
490                dim)
491               ((= (length dims) 1)
492                (ecase (conservative-array-type-complexp array-type)
493                  ((t)
494                   '(%array-dimension array 0))
495                  ((nil)
496                   '(length array))
497                  ((:maybe)
498                   (give-up-ir1-transform
499                    "can't tell whether array is simple"))))
500               (t
501                '(%array-dimension array axis)))))))
502
503 ;;; If the length has been declared and it's simple, just return it.
504 (deftransform length ((vector)
505                       ((simple-array * (*))))
506   (let ((type (lvar-type vector)))
507     (let ((dims (array-type-dimensions-or-give-up type)))
508       (unless (and (listp dims) (integerp (car dims)))
509         (give-up-ir1-transform
510          "Vector length is unknown, must call LENGTH at runtime."))
511       (car dims))))
512
513 ;;; All vectors can get their length by using VECTOR-LENGTH. If it's
514 ;;; simple, it will extract the length slot from the vector. It it's
515 ;;; complex, it will extract the fill pointer slot from the array
516 ;;; header.
517 (deftransform length ((vector) (vector))
518   '(vector-length vector))
519
520 ;;; If a simple array with known dimensions, then VECTOR-LENGTH is a
521 ;;; compile-time constant.
522 (deftransform vector-length ((vector))
523   (let ((vtype (lvar-type vector)))
524     (let ((dim (first (array-type-dimensions-or-give-up vtype))))
525       (when (eq dim '*)
526         (give-up-ir1-transform))
527       (when (conservative-array-type-complexp vtype)
528         (give-up-ir1-transform))
529       dim)))
530
531 ;;; Again, if we can tell the results from the type, just use it.
532 ;;; Otherwise, if we know the rank, convert into a computation based
533 ;;; on array-dimension. We can wrap a TRULY-THE INDEX around the
534 ;;; multiplications because we know that the total size must be an
535 ;;; INDEX.
536 (deftransform array-total-size ((array)
537                                 (array))
538   (let ((array-type (lvar-type array)))
539     (let ((dims (array-type-dimensions-or-give-up array-type)))
540       (unless (listp dims)
541         (give-up-ir1-transform "can't tell the rank at compile time"))
542       (if (member '* dims)
543           (do ((form 1 `(truly-the index
544                                    (* (array-dimension array ,i) ,form)))
545                (i 0 (1+ i)))
546               ((= i (length dims)) form))
547           (reduce #'* dims)))))
548
549 ;;; Only complex vectors have fill pointers.
550 (deftransform array-has-fill-pointer-p ((array))
551   (let ((array-type (lvar-type array)))
552     (let ((dims (array-type-dimensions-or-give-up array-type)))
553       (if (and (listp dims) (not (= (length dims) 1)))
554           nil
555           (ecase (conservative-array-type-complexp array-type)
556             ((t)
557              t)
558             ((nil)
559              nil)
560             ((:maybe)
561              (give-up-ir1-transform
562               "The array type is ambiguous; must call ~
563                ARRAY-HAS-FILL-POINTER-P at runtime.")))))))
564
565 ;;; Primitive used to verify indices into arrays. If we can tell at
566 ;;; compile-time or we are generating unsafe code, don't bother with
567 ;;; the VOP.
568 (deftransform %check-bound ((array dimension index) * * :node node)
569   (cond ((policy node (= insert-array-bounds-checks 0))
570          'index)
571         ((not (constant-lvar-p dimension))
572          (give-up-ir1-transform))
573         (t
574          (let ((dim (lvar-value dimension)))
575            ;; FIXME: Can SPEED > SAFETY weaken this check to INTEGER?
576            `(the (integer 0 (,dim)) index)))))
577 \f
578 ;;;; WITH-ARRAY-DATA
579
580 ;;; This checks to see whether the array is simple and the start and
581 ;;; end are in bounds. If so, it proceeds with those values.
582 ;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that %WITH-ARRAY-DATA
583 ;;; may be further optimized.
584 ;;;
585 ;;; Given any ARRAY, bind DATA-VAR to the array's data vector and
586 ;;; START-VAR and END-VAR to the start and end of the designated
587 ;;; portion of the data vector. SVALUE and EVALUE are any start and
588 ;;; end specified to the original operation, and are factored into the
589 ;;; bindings of START-VAR and END-VAR. OFFSET-VAR is the cumulative
590 ;;; offset of all displacements encountered, and does not include
591 ;;; SVALUE.
592 ;;;
593 ;;; When FORCE-INLINE is set, the underlying %WITH-ARRAY-DATA form is
594 ;;; forced to be inline, overriding the ordinary judgment of the
595 ;;; %WITH-ARRAY-DATA DEFTRANSFORMs. Ordinarily the DEFTRANSFORMs are
596 ;;; fairly picky about their arguments, figuring that if you haven't
597 ;;; bothered to get all your ducks in a row, you probably don't care
598 ;;; that much about speed anyway! But in some cases it makes sense to
599 ;;; do type testing inside %WITH-ARRAY-DATA instead of outside, and
600 ;;; the DEFTRANSFORM can't tell that that's going on, so it can make
601 ;;; sense to use FORCE-INLINE option in that case.
602 (def!macro with-array-data (((data-var array &key offset-var)
603                              (start-var &optional (svalue 0))
604                              (end-var &optional (evalue nil))
605                              &key force-inline check-fill-pointer)
606                             &body forms
607                             &environment env)
608   (once-only ((n-array array)
609               (n-svalue `(the index ,svalue))
610               (n-evalue `(the (or index null) ,evalue)))
611     (let ((check-bounds (policy env (plusp insert-array-bounds-checks))))
612       `(multiple-value-bind (,data-var
613                              ,start-var
614                              ,end-var
615                              ,@(when offset-var `(,offset-var)))
616            (if (not (array-header-p ,n-array))
617                (let ((,n-array ,n-array))
618                  (declare (type (simple-array * (*)) ,n-array))
619                  ,(once-only ((n-len (if check-fill-pointer
620                                          `(length ,n-array)
621                                          `(array-total-size ,n-array)))
622                               (n-end `(or ,n-evalue ,n-len)))
623                              (if check-bounds
624                                  `(if (<= 0 ,n-svalue ,n-end ,n-len)
625                                       (values ,n-array ,n-svalue ,n-end 0)
626                                       ,(if check-fill-pointer
627                                            `(sequence-bounding-indices-bad-error ,n-array ,n-svalue ,n-evalue)
628                                            `(array-bounding-indices-bad-error ,n-array ,n-svalue ,n-evalue)))
629                                  `(values ,n-array ,n-svalue ,n-end 0))))
630                ,(if force-inline
631                     `(%with-array-data-macro ,n-array ,n-svalue ,n-evalue
632                                              :check-bounds ,check-bounds
633                                              :check-fill-pointer ,check-fill-pointer)
634                     (if check-fill-pointer
635                         `(%with-array-data/fp ,n-array ,n-svalue ,n-evalue)
636                         `(%with-array-data ,n-array ,n-svalue ,n-evalue))))
637          ,@forms))))
638
639 ;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in
640 ;;; DEFTRANSFORMs and DEFUNs.
641 (def!macro %with-array-data-macro (array
642                                    start
643                                    end
644                                    &key
645                                    (element-type '*)
646                                    check-bounds
647                                    check-fill-pointer)
648   (with-unique-names (size defaulted-end data cumulative-offset)
649     `(let* ((,size ,(if check-fill-pointer
650                         `(length ,array)
651                         `(array-total-size ,array)))
652             (,defaulted-end (or ,end ,size)))
653        ,@(when check-bounds
654                `((unless (<= ,start ,defaulted-end ,size)
655                    ,(if check-fill-pointer
656                         `(sequence-bounding-indices-bad-error ,array ,start ,end)
657                         `(array-bounding-indices-bad-error ,array ,start ,end)))))
658        (do ((,data ,array (%array-data-vector ,data))
659             (,cumulative-offset 0
660                                 (+ ,cumulative-offset
661                                    (%array-displacement ,data))))
662            ((not (array-header-p ,data))
663             (values (the (simple-array ,element-type 1) ,data)
664                     (the index (+ ,cumulative-offset ,start))
665                     (the index (+ ,cumulative-offset ,defaulted-end))
666                     (the index ,cumulative-offset)))
667          (declare (type index ,cumulative-offset))))))
668
669 (defun transform-%with-array-data/muble (array node check-fill-pointer)
670   (let ((element-type (upgraded-element-type-specifier-or-give-up array))
671         (type (lvar-type array))
672         (check-bounds (policy node (plusp insert-array-bounds-checks))))
673     (if (and (array-type-p type)
674              (not (array-type-complexp type))
675              (listp (array-type-dimensions type))
676              (not (null (cdr (array-type-dimensions type)))))
677         ;; If it's a simple multidimensional array, then just return
678         ;; its data vector directly rather than going through
679         ;; %WITH-ARRAY-DATA-MACRO. SBCL doesn't generally generate
680         ;; code that would use this currently, but we have encouraged
681         ;; users to use WITH-ARRAY-DATA and we may use it ourselves at
682         ;; some point in the future for optimized libraries or
683         ;; similar.
684         (if check-bounds
685             `(let* ((data (truly-the (simple-array ,element-type (*))
686                                      (%array-data-vector array)))
687                     (len (length data))
688                     (real-end (or end len)))
689                (unless (<= 0 start data-end lend)
690                  (sequence-bounding-indices-bad-error array start end))
691                (values data 0 real-end 0))
692             `(let ((data (truly-the (simple-array ,element-type (*))
693                                     (%array-data-vector array))))
694                (values data 0 (or end (length data)) 0)))
695         `(%with-array-data-macro array start end
696                                  :check-fill-pointer ,check-fill-pointer
697                                  :check-bounds ,check-bounds
698                                  :element-type ,element-type))))
699
700 ;; It might very well be reasonable to allow general ARRAY here, I
701 ;; just haven't tried to understand the performance issues involved.
702 ;; -- WHN, and also CSR 2002-05-26
703 (deftransform %with-array-data ((array start end)
704                                 ((or vector simple-array) index (or index null) t)
705                                 *
706                                 :node node
707                                 :policy (> speed space))
708   "inline non-SIMPLE-vector-handling logic"
709   (transform-%with-array-data/muble array node nil))
710 (deftransform %with-array-data/fp ((array start end)
711                                 ((or vector simple-array) index (or index null) t)
712                                 *
713                                 :node node
714                                 :policy (> speed space))
715   "inline non-SIMPLE-vector-handling logic"
716   (transform-%with-array-data/muble array node t))
717 \f
718 ;;;; array accessors
719
720 ;;; We convert all typed array accessors into AREF and %ASET with type
721 ;;; assertions on the array.
722 (macrolet ((define-bit-frob (reffer setter simplep)
723              `(progn
724                 (define-source-transform ,reffer (a &rest i)
725                   `(aref (the (,',(if simplep 'simple-array 'array)
726                                   bit
727                                   ,(mapcar (constantly '*) i))
728                            ,a) ,@i))
729                 (define-source-transform ,setter (a &rest i)
730                   `(%aset (the (,',(if simplep 'simple-array 'array)
731                                    bit
732                                    ,(cdr (mapcar (constantly '*) i)))
733                             ,a) ,@i)))))
734   (define-bit-frob sbit %sbitset t)
735   (define-bit-frob bit %bitset nil))
736 (macrolet ((define-frob (reffer setter type)
737              `(progn
738                 (define-source-transform ,reffer (a i)
739                   `(aref (the ,',type ,a) ,i))
740                 (define-source-transform ,setter (a i v)
741                   `(%aset (the ,',type ,a) ,i ,v)))))
742   (define-frob svref %svset simple-vector)
743   (define-frob schar %scharset simple-string)
744   (define-frob char %charset string))
745
746 (macrolet (;; This is a handy macro for computing the row-major index
747            ;; given a set of indices. We wrap each index with a call
748            ;; to %CHECK-BOUND to ensure that everything works out
749            ;; correctly. We can wrap all the interior arithmetic with
750            ;; TRULY-THE INDEX because we know the resultant
751            ;; row-major index must be an index.
752            (with-row-major-index ((array indices index &optional new-value)
753                                   &rest body)
754              `(let (n-indices dims)
755                 (dotimes (i (length ,indices))
756                   (push (make-symbol (format nil "INDEX-~D" i)) n-indices)
757                   (push (make-symbol (format nil "DIM-~D" i)) dims))
758                 (setf n-indices (nreverse n-indices))
759                 (setf dims (nreverse dims))
760                 `(lambda (,',array ,@n-indices
761                                    ,@',(when new-value (list new-value)))
762                    (let* (,@(let ((,index -1))
763                               (mapcar (lambda (name)
764                                         `(,name (array-dimension
765                                                  ,',array
766                                                  ,(incf ,index))))
767                                       dims))
768                             (,',index
769                              ,(if (null dims)
770                                   0
771                                 (do* ((dims dims (cdr dims))
772                                       (indices n-indices (cdr indices))
773                                       (last-dim nil (car dims))
774                                       (form `(%check-bound ,',array
775                                                            ,(car dims)
776                                                            ,(car indices))
777                                             `(truly-the
778                                               index
779                                               (+ (truly-the index
780                                                             (* ,form
781                                                                ,last-dim))
782                                                  (%check-bound
783                                                   ,',array
784                                                   ,(car dims)
785                                                   ,(car indices))))))
786                                     ((null (cdr dims)) form)))))
787                      ,',@body)))))
788
789   ;; Just return the index after computing it.
790   (deftransform array-row-major-index ((array &rest indices))
791     (with-row-major-index (array indices index)
792       index))
793
794   ;; Convert AREF and %ASET into a HAIRY-DATA-VECTOR-REF (or
795   ;; HAIRY-DATA-VECTOR-SET) with the set of indices replaced with the an
796   ;; expression for the row major index.
797   (deftransform aref ((array &rest indices))
798     (with-row-major-index (array indices index)
799       (hairy-data-vector-ref array index)))
800
801   (deftransform %aset ((array &rest stuff))
802     (let ((indices (butlast stuff)))
803       (with-row-major-index (array indices index new-value)
804         (hairy-data-vector-set array index new-value)))))
805
806 ;; For AREF of vectors we do the bounds checking in the callee. This
807 ;; lets us do a significantly more efficient check for simple-arrays
808 ;; without bloating the code. If we already know the type of the array
809 ;; with sufficient precision, skip directly to DATA-VECTOR-REF.
810 (deftransform aref ((array index) (t t) * :node node)
811   (let* ((type (lvar-type array))
812          (element-ctype (extract-upgraded-element-type array)))
813     (cond
814       ((and (array-type-p type)
815             (null (array-type-complexp type))
816             (not (eql element-ctype *wild-type*))
817             (eql (length (array-type-dimensions type)) 1))
818        (let* ((declared-element-ctype (extract-declared-element-type array))
819               (bare-form
820                `(data-vector-ref array
821                  (%check-bound array (array-dimension array 0) index))))
822          (if (type= declared-element-ctype element-ctype)
823              bare-form
824              `(the ,(type-specifier declared-element-ctype) ,bare-form))))
825       ((policy node (zerop insert-array-bounds-checks))
826        `(hairy-data-vector-ref array index))
827       (t `(hairy-data-vector-ref/check-bounds array index)))))
828
829 (deftransform %aset ((array index new-value) (t t t) * :node node)
830   (if (policy node (zerop insert-array-bounds-checks))
831       `(hairy-data-vector-set array index new-value)
832       `(hairy-data-vector-set/check-bounds array index new-value)))
833
834 ;;; But if we find out later that there's some useful type information
835 ;;; available, switch back to the normal one to give other transforms
836 ;;; a stab at it.
837 (macrolet ((define (name transform-to extra extra-type)
838              (declare (ignore extra-type))
839              `(deftransform ,name ((array index ,@extra))
840                 (let ((type (lvar-type array))
841                       (element-type (extract-upgraded-element-type array)))
842                   ;; If an element type has been declared, we want to
843                   ;; use that information it for type checking (even
844                   ;; if the access can't be optimized due to the array
845                   ;; not being simple).
846                   (when (and (eql element-type *wild-type*)
847                              ;; This type logic corresponds to the special
848                              ;; case for strings in HAIRY-DATA-VECTOR-REF
849                              ;; (generic/vm-tran.lisp)
850                              (not (csubtypep type (specifier-type 'simple-string))))
851                     (when (or (not (array-type-p type))
852                               ;; If it's a simple array, we might be able
853                               ;; to inline the access completely.
854                               (not (null (array-type-complexp type))))
855                       (give-up-ir1-transform
856                        "Upgraded element type of array is not known at compile time."))))
857                 `(,',transform-to array
858                                   (%check-bound array
859                                                 (array-dimension array 0)
860                                                 index)
861                                   ,@',extra))))
862   (define hairy-data-vector-ref/check-bounds
863       hairy-data-vector-ref nil nil)
864   (define hairy-data-vector-set/check-bounds
865       hairy-data-vector-set (new-value) (*)))
866
867 ;;; Just convert into a HAIRY-DATA-VECTOR-REF (or
868 ;;; HAIRY-DATA-VECTOR-SET) after checking that the index is inside the
869 ;;; array total size.
870 (deftransform row-major-aref ((array index))
871   `(hairy-data-vector-ref array
872                           (%check-bound array (array-total-size array) index)))
873 (deftransform %set-row-major-aref ((array index new-value))
874   `(hairy-data-vector-set array
875                           (%check-bound array (array-total-size array) index)
876                           new-value))
877 \f
878 ;;;; bit-vector array operation canonicalization
879 ;;;;
880 ;;;; We convert all bit-vector operations to have the result array
881 ;;;; specified. This allows any result allocation to be open-coded,
882 ;;;; and eliminates the need for any VM-dependent transforms to handle
883 ;;;; these cases.
884
885 (macrolet ((def (fun)
886              `(progn
887                (deftransform ,fun ((bit-array-1 bit-array-2
888                                                 &optional result-bit-array)
889                                    (bit-vector bit-vector &optional null) *
890                                    :policy (>= speed space))
891                  `(,',fun bit-array-1 bit-array-2
892                    (make-array (array-dimension bit-array-1 0) :element-type 'bit)))
893                ;; If result is T, make it the first arg.
894                (deftransform ,fun ((bit-array-1 bit-array-2 result-bit-array)
895                                    (bit-vector bit-vector (eql t)) *)
896                  `(,',fun bit-array-1 bit-array-2 bit-array-1)))))
897   (def bit-and)
898   (def bit-ior)
899   (def bit-xor)
900   (def bit-eqv)
901   (def bit-nand)
902   (def bit-nor)
903   (def bit-andc1)
904   (def bit-andc2)
905   (def bit-orc1)
906   (def bit-orc2))
907
908 ;;; Similar for BIT-NOT, but there is only one arg...
909 (deftransform bit-not ((bit-array-1 &optional result-bit-array)
910                        (bit-vector &optional null) *
911                        :policy (>= speed space))
912   '(bit-not bit-array-1
913             (make-array (array-dimension bit-array-1 0) :element-type 'bit)))
914 (deftransform bit-not ((bit-array-1 result-bit-array)
915                        (bit-vector (eql t)))
916   '(bit-not bit-array-1 bit-array-1))
917 \f
918 ;;; Pick off some constant cases.
919 (defoptimizer (array-header-p derive-type) ((array))
920   (let ((type (lvar-type array)))
921     (cond ((not (array-type-p type))
922            ;; FIXME: use analogue of ARRAY-TYPE-DIMENSIONS-OR-GIVE-UP
923            nil)
924           (t
925            (let ((dims (array-type-dimensions type)))
926              (cond ((csubtypep type (specifier-type '(simple-array * (*))))
927                     ;; no array header
928                     (specifier-type 'null))
929                    ((and (listp dims) (/= (length dims) 1))
930                     ;; multi-dimensional array, will have a header
931                     (specifier-type '(eql t)))
932                    ((eql (array-type-complexp type) t)
933                     (specifier-type '(eql t)))
934                    (t
935                     nil)))))))