/[cmucl]/src/compiler/array-tran.lisp
ViewVC logotype

Contents of /src/compiler/array-tran.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.37 - (show annotations)
Fri Jan 7 21:47:18 2005 UTC (9 years, 3 months ago) by rtoy
Branch: MAIN
CVS Tags: ppc_gencgc_snap_2005-05-14, snapshot-2005-02
Branch point for: ppc_gencgc_branch
Changes since 1.36: +19 -2 lines
This function from the misc.492 test from ansi-tests:

(defun fn-492 (r p1)
  (declare (optimize speed (safety 1))
	   (type (simple-array (signed-byte 8) nil) r) (type (integer * 22050378) p1))
  (setf (aref r) (lognand (the (integer 19464371) p1) 2257))
  (values))

confuses the compiler and causes (values) to be deleted, and also
deletes the return from the function so we just run past the end into
junk.

I think it's caused by confusion in type derivation.  I changed the
defoptimizer for %aset so it returns the specialized element-type of
the array instead of the new-value.

This is a workaround, not a solution.
1 ;;; -*- Package: C; Log: C.Log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/array-tran.lisp,v 1.37 2005/01/07 21:47:18 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains array specific optimizers and transforms.
13 ;;;
14 ;;; Extracted from srctran and extended by William Lott.
15 ;;;
16 (in-package "C")
17
18
19 ;;;; Derive-Type Optimizers
20
21 ;;; ASSERT-ARRAY-RANK -- internal
22 ;;;
23 ;;; Array operations that use a specific number of indices implicitly assert
24 ;;; that the array is of that rank.
25 ;;;
26 (defun assert-array-rank (array rank)
27 (assert-continuation-type
28 array
29 (specifier-type `(array * ,(make-list rank :initial-element '*)))))
30
31 ;;; EXTRACT-ELEMENT-TYPE -- internal
32 ;;;
33 ;;; Array access functions return an object from the array, hence it's
34 ;;; type will be asserted to be array element type.
35 ;;;
36 (defun extract-element-type (array)
37 (let ((type (continuation-type array)))
38 (if (array-type-p type)
39 (array-type-element-type type)
40 *universal-type*)))
41
42 ;;; EXTRACT-UPGRADED-ELEMENT-TYPE -- internal
43 ;;;
44 ;;; Array access functions return an object from the array, hence it's
45 ;;; type is going to be the array upgraded element type.
46 ;;;
47 (defun extract-upgraded-element-type (array)
48 (let ((type (continuation-type array)))
49 (if (array-type-p type)
50 (array-type-specialized-element-type type)
51 *universal-type*)))
52
53 ;;; ASSERT-NEW-VALUE-TYPE -- internal
54 ;;;
55 ;;; The ``new-value'' for array setters must fit in the array, and the
56 ;;; return type is going to be the same as the new-value for setf functions.
57 ;;;
58 (defun assert-new-value-type (new-value array)
59 (let ((type (continuation-type array)))
60 (when (array-type-p type)
61 (assert-continuation-optional-type new-value
62 (array-type-specialized-element-type type))))
63 (continuation-type new-value))
64
65 ;;; Unsupplied-Or-NIL -- Internal
66 ;;;
67 ;;; Return true if Arg is NIL, or is a constant-continuation whose value is
68 ;;; NIL, false otherwise.
69 ;;;
70 (defun unsupplied-or-nil (arg)
71 (declare (type (or continuation null) arg))
72 (or (not arg)
73 (and (constant-continuation-p arg)
74 (not (continuation-value arg)))))
75
76
77 ;;; ARRAY-IN-BOUNDS-P -- derive-type optimizer.
78 ;;;
79 (defoptimizer (array-in-bounds-p derive-type) ((array &rest indices))
80 (assert-array-rank array (length indices))
81 *universal-type*)
82
83 ;;; AREF -- derive-type optimizer.
84 ;;;
85 (defoptimizer (aref derive-type) ((array &rest indices) node)
86 (assert-array-rank array (length indices))
87 ;; If the node continuation has a single use then assert its type.
88 ;;
89 ;; Let's not do this. As reported by Lynn Quam on cmucl-imp on
90 ;; 2004-03-30, the compiler generates bogus code for
91 ;;
92 ;; (defun foo (f d)
93 ;; (declare (type (simple-array single-float (*)) f)
94 ;; (type (simple-array double-float (*)) d))
95 ;; (setf (aref f 0) (aref d 0)))
96 ;;
97 ;; and doesn't even warn about the type mismatch. This might be a
98 ;; symptom of other compiler bugs, but removing this at least gives
99 ;; us back the warning. I (RLT) do not know what impact removing
100 ;; this has on other user code.
101 #+(or)
102 (let ((cont (node-cont node)))
103 (when (= (length (find-uses cont)) 1)
104 (assert-continuation-type cont (extract-upgraded-element-type array))))
105 (extract-upgraded-element-type array))
106
107 ;;; %ASET -- derive-type optimizer.
108 ;;;
109 (defoptimizer (%aset derive-type) ((array &rest stuff))
110 (assert-array-rank array (1- (length stuff)))
111 (assert-new-value-type (car (last stuff)) array)
112 ;; Without the following, this function
113 ;;
114 ;; (defun fn-492 (r p1)
115 ;; (declare (optimize speed (safety 1))
116 ;; (type (simple-array (signed-byte 8) nil) r) (type (integer * 22050378) p1))
117 ;; (setf (aref r) (lognand (the (integer 19464371) p1) 2257))
118 ;; (values))
119 ;;
120 ;; causes the compiler to delete (values) as unreachable and in so
121 ;; doing, deletes the return, so we just run off the end. I (rtoy)
122 ;; think this is caused by some confusion in type-derivation. The
123 ;; derived result of the lognand is bigger than a (signed-byte 8).
124 ;;
125 ;; I think doing this also causes some loss, because we return the
126 ;; element-type of the array, even though the result of the aset is
127 ;; the new value.
128 (array-type-specialized-element-type (continuation-type array)))
129
130 ;;; DATA-VECTOR-REF -- derive-type optimizer.
131 ;;;
132 (defoptimizer (data-vector-ref derive-type) ((array index))
133 (extract-upgraded-element-type array))
134
135 ;;; DATA-VECTOR-SET -- derive-type optimizer.
136 ;;;
137 (defoptimizer (data-vector-set derive-type) ((array index new-value))
138 (assert-new-value-type new-value array))
139
140 ;;; %WITH-ARRAY-DATA -- derive-type optimizer.
141 ;;;
142 ;;; Figure out the type of the data vector if we know the argument element
143 ;;; type.
144 ;;;
145 (defoptimizer (%with-array-data derive-type) ((array start end))
146 (let ((atype (continuation-type array)))
147 (when (array-type-p atype)
148 (values-specifier-type
149 `(values (simple-array ,(type-specifier
150 (array-type-element-type atype))
151 (*))
152 index index index)))))
153
154
155 ;;; ARRAY-ROW-MAJOR-INDEX -- derive-type optimizer.
156 ;;;
157 (defoptimizer (array-row-major-index derive-type) ((array &rest indices))
158 (assert-array-rank array (length indices))
159 *universal-type*)
160
161 ;;; ROW-MAJOR-AREF -- derive-type optimizer.
162 ;;;
163 (defoptimizer (row-major-aref derive-type) ((array index))
164 (extract-upgraded-element-type array))
165
166 ;;; %SET-ROW-MAJOR-AREF -- derive-type optimizer.
167 ;;;
168 (defoptimizer (%set-row-major-aref derive-type) ((array index new-value))
169 (assert-new-value-type new-value array))
170
171 ;;; MAKE-ARRAY -- derive-type optimizer.
172 ;;;
173 (defoptimizer (make-array derive-type)
174 ((dims &key initial-element element-type initial-contents
175 adjustable fill-pointer displaced-index-offset displaced-to))
176 (let ((simple (and (unsupplied-or-nil adjustable)
177 (unsupplied-or-nil displaced-to)
178 (unsupplied-or-nil fill-pointer))))
179 (specifier-type
180 `(,(if simple 'simple-array 'array)
181 ,(cond ((not element-type) 't)
182 ((constant-continuation-p element-type)
183 (continuation-value element-type))
184 (t
185 '*))
186 ,(cond ((not simple)
187 '*)
188 ((constant-continuation-p dims)
189 (let ((val (continuation-value dims)))
190 (if (listp val) val (list val))))
191 ((csubtypep (continuation-type dims)
192 (specifier-type 'integer))
193 '(*))
194 (t
195 '*))))))
196
197
198 ;;;; Constructors.
199
200 ;;; VECTOR -- source-transform.
201 ;;;
202 ;;; Convert VECTOR into a make-array followed by setfs of all the elements.
203 ;;;
204 (def-source-transform vector (&rest elements)
205 (if (byte-compiling)
206 (values nil t)
207 (let ((len (length elements))
208 (n -1))
209 (once-only ((n-vec `(make-array ,len)))
210 `(progn
211 ,@(mapcar #'(lambda (el)
212 (once-only ((n-val el))
213 `(locally (declare (optimize (safety 0)))
214 (setf (svref ,n-vec ,(incf n))
215 ,n-val))))
216 elements)
217 ,n-vec)))))
218
219
220 ;;; MAKE-STRING -- source-transform.
221 ;;;
222 ;;; Just convert it into a make-array.
223 ;;;
224 (deftransform make-string ((length &key (element-type 'base-char)
225 (initial-element #\NULL)))
226 `(make-array (the (values index &rest t) length)
227 :element-type element-type
228 :initial-element initial-element))
229
230 (defconstant array-info
231 '((base-char #\NULL 8 vm:simple-string-type)
232 (single-float 0.0f0 32 vm:simple-array-single-float-type)
233 (double-float 0.0d0 64 vm:simple-array-double-float-type)
234 #+long-float (long-float 0.0l0 #+x86 96 #+sparc 128
235 vm:simple-array-long-float-type)
236 (bit 0 1 vm:simple-bit-vector-type)
237 ((unsigned-byte 2) 0 2 vm:simple-array-unsigned-byte-2-type)
238 ((unsigned-byte 4) 0 4 vm:simple-array-unsigned-byte-4-type)
239 ((unsigned-byte 8) 0 8 vm:simple-array-unsigned-byte-8-type)
240 ((unsigned-byte 16) 0 16 vm:simple-array-unsigned-byte-16-type)
241 ((unsigned-byte 32) 0 32 vm:simple-array-unsigned-byte-32-type)
242 ((signed-byte 8) 0 8 vm:simple-array-signed-byte-8-type)
243 ((signed-byte 16) 0 16 vm:simple-array-signed-byte-16-type)
244 ((signed-byte 30) 0 32 vm:simple-array-signed-byte-30-type)
245 ((signed-byte 32) 0 32 vm:simple-array-signed-byte-32-type)
246 ((complex single-float) #C(0.0f0 0.0f0) 64
247 vm:simple-array-complex-single-float-type)
248 ((complex double-float) #C(0.0d0 0.0d0) 128
249 vm:simple-array-complex-double-float-type)
250 #+long-float
251 ((complex long-float) #C(0.0l0 0.0l0) #+x86 192 #+sparc 256
252 vm:simple-array-complex-long-float-type)
253 (t 0 32 vm:simple-vector-type)))
254
255 ;;; MAKE-ARRAY -- source-transform.
256 ;;;
257 ;;; The integer type restriction on the length assures that it will be a
258 ;;; vector. The lack of adjustable, fill-pointer, and displaced-to keywords
259 ;;; assures that it will be simple.
260 ;;;
261 (deftransform make-array ((length &key initial-element element-type)
262 (integer &rest *))
263 (let* ((eltype (cond ((not element-type) t)
264 ((not (constant-continuation-p element-type))
265 (give-up "Element-Type is not constant."))
266 (t
267 (continuation-value element-type))))
268 (len (if (constant-continuation-p length)
269 (continuation-value length)
270 '*))
271 (spec `(simple-array ,eltype (,len)))
272 (eltype-type (specifier-type eltype)))
273 (multiple-value-bind
274 (default-initial-element element-size typecode)
275 (dolist (info array-info
276 (give-up "Cannot open-code creation of ~S" spec))
277 (when (csubtypep eltype-type (specifier-type (car info)))
278 (return (values-list (cdr info)))))
279 (let* ((nwords-form
280 (if (>= element-size vm:word-bits)
281 `(* length ,(/ element-size vm:word-bits))
282 (let ((elements-per-word (/ 32 element-size)))
283 `(truncate (+ length
284 ,(if (eq 'vm:simple-string-type typecode)
285 elements-per-word
286 (1- elements-per-word)))
287 ,elements-per-word))))
288 (constructor
289 `(truly-the ,spec
290 (allocate-vector ,typecode length ,nwords-form))))
291 (values
292 (cond ((and default-initial-element
293 (or (null initial-element)
294 (and (constant-continuation-p initial-element)
295 (eql (continuation-value initial-element)
296 default-initial-element))))
297 (unless (csubtypep (ctype-of default-initial-element)
298 eltype-type)
299 (compiler-note "Default initial element ~s is not a ~s."
300 default-initial-element eltype))
301 constructor)
302 (t
303 `(truly-the ,spec (fill ,constructor initial-element))))
304 '((declare (type index length))))))))
305
306 ;;; MAKE-ARRAY -- transform.
307 ;;;
308 ;;; The list type restriction does not assure that the result will be a
309 ;;; multi-dimensional array. But the lack of
310 ;;;
311 (deftransform make-array ((dims &key initial-element element-type)
312 (list &rest *))
313 (unless (or (null element-type) (constant-continuation-p element-type))
314 (give-up "Element-type not constant; cannot open code array creation"))
315 (unless (constant-continuation-p dims)
316 (give-up "Dimension list not constant; cannot open code array creation"))
317 (let ((dims (continuation-value dims)))
318 (unless (every #'integerp dims)
319 (give-up "Dimension list contains something other than an integer: ~S"
320 dims))
321 (if (= (length dims) 1)
322 `(make-array ',(car dims)
323 ,@(when initial-element
324 '(:initial-element initial-element))
325 ,@(when element-type
326 '(:element-type element-type)))
327 (let* ((total-size (reduce #'* dims))
328 (rank (length dims))
329 (spec `(simple-array
330 ,(cond ((null element-type) t)
331 ((constant-continuation-p element-type)
332 (continuation-value element-type))
333 (t '*))
334 ,(make-list rank :initial-element '*))))
335 `(let ((header (make-array-header vm:simple-array-type ,rank)))
336 (setf (%array-fill-pointer header) ,total-size)
337 (setf (%array-fill-pointer-p header) nil)
338 (setf (%array-available-elements header) ,total-size)
339 (setf (%array-data-vector header)
340 (make-array ,total-size
341 ,@(when element-type
342 '(:element-type element-type))
343 ,@(when initial-element
344 '(:initial-element initial-element))))
345 (setf (%array-displaced-p header) nil)
346 ,@(let ((axis -1))
347 (mapcar #'(lambda (dim)
348 `(setf (%array-dimension header ,(incf axis))
349 ,dim))
350 dims))
351 (truly-the ,spec header))))))
352
353
354 ;;;; Random properties of arrays.
355
356 ;;; Transforms for various random array properties. If the property is know
357 ;;; at compile time because of a type spec, use that constant value.
358
359 ;;; ARRAY-RANK -- transform.
360 ;;;
361 ;;; If we can tell the rank from the type info, use it instead.
362 ;;;
363 (deftransform array-rank ((array))
364 (let ((array-type (continuation-type array)))
365 (unless (array-type-p array-type)
366 (give-up))
367 (let ((dims (array-type-dimensions array-type)))
368 (if (not (listp dims))
369 (give-up "Array rank not known at compile time: ~S" dims)
370 (length dims)))))
371
372 ;;; ARRAY-DIMENSION -- transform.
373 ;;;
374 ;;; If we know the dimensions at compile time, just use it. Otherwise, if
375 ;;; we can tell that the axis is in bounds, convert to %array-dimension
376 ;;; (which just indirects the array header) or length (if it's simple and a
377 ;;; vector).
378 ;;;
379 (deftransform array-dimension ((array axis)
380 (array index))
381 (unless (constant-continuation-p axis)
382 (give-up "Axis not constant."))
383 (let ((array-type (continuation-type array))
384 (axis (continuation-value axis)))
385 (unless (array-type-p array-type)
386 (give-up))
387 (let ((dims (array-type-dimensions array-type)))
388 (unless (listp dims)
389 (give-up
390 "Array dimensions unknown, must call array-dimension at runtime."))
391 (unless (> (length dims) axis)
392 (abort-transform "Array has dimensions ~S, ~D is too large."
393 dims axis))
394 (let ((dim (nth axis dims)))
395 (cond ((integerp dim)
396 dim)
397 ((= (length dims) 1)
398 (ecase (array-type-complexp array-type)
399 ((t)
400 '(%array-dimension array 0))
401 ((nil)
402 '(length array))
403 ((:maybe *)
404 (give-up "Can't tell if array is simple."))))
405 (t
406 '(%array-dimension array axis)))))))
407
408 ;;; LENGTH -- transform.
409 ;;;
410 ;;; If the length has been declared and it's simple, just return it.
411 ;;;
412 (deftransform length ((vector)
413 ((simple-array * (*))))
414 (let ((type (continuation-type vector)))
415 (unless (array-type-p type)
416 (give-up))
417 (let ((dims (array-type-dimensions type)))
418 (unless (and (listp dims) (integerp (car dims)))
419 (give-up "Vector length unknown, must call length at runtime."))
420 (car dims))))
421
422 ;;; LENGTH -- transform.
423 ;;;
424 ;;; All vectors can get their length by using vector-length. If it's simple,
425 ;;; it will extract the length slot from the vector. It it's complex, it will
426 ;;; extract the fill pointer slot from the array header.
427 ;;;
428 (deftransform length ((vector) (vector))
429 '(vector-length vector))
430
431
432 ;;; If a simple array with known dimensions, then vector-length is a
433 ;;; compile-time constant.
434 ;;;
435 (deftransform vector-length ((vector) ((simple-array * (*))))
436 (let ((vtype (continuation-type vector)))
437 (if (array-type-p vtype)
438 (let ((dim (first (array-type-dimensions vtype))))
439 (when (eq dim '*) (give-up))
440 dim)
441 (give-up))))
442
443
444 ;;; ARRAY-TOTAL-SIZE -- transform.
445 ;;;
446 ;;; Again, if we can tell the results from the type, just use it. Otherwise,
447 ;;; if we know the rank, convert into a computation based on array-dimension.
448 ;;; We can wrap a truly-the index around the multiplications because we know
449 ;;; that the total size must be an index.
450 ;;;
451 (deftransform array-total-size ((array)
452 (array))
453 (let ((array-type (continuation-type array)))
454 (unless (array-type-p array-type)
455 (give-up))
456 (let ((dims (array-type-dimensions array-type)))
457 (unless (listp dims)
458 (give-up "Can't tell the rank at compile time."))
459 (if (member '* dims)
460 (do ((form 1 `(truly-the index
461 (* (array-dimension array ,i) ,form)))
462 (i 0 (1+ i)))
463 ((= i (length dims)) form))
464 (reduce #'* dims)))))
465
466 ;;; ARRAY-HAS-FILL-POINTER-P -- transform.
467 ;;;
468 ;;; Only complex vectors have fill pointers.
469 ;;;
470 (deftransform array-has-fill-pointer-p ((array))
471 (let ((array-type (continuation-type array)))
472 (unless (array-type-p array-type)
473 (give-up))
474 (let ((dims (array-type-dimensions array-type)))
475 (if (and (listp dims) (not (= (length dims) 1)))
476 nil
477 (ecase (array-type-complexp array-type)
478 ((t)
479 t)
480 ((nil)
481 nil)
482 (*
483 (give-up "Array type ambiguous; must call ~
484 array-has-fill-pointer-p at runtime.")))))))
485
486 ;;; %CHECK-BOUND -- transform.
487 ;;;
488 ;;; Primitive used to verify indicies into arrays. If we can tell at
489 ;;; compile-time or we are generating unsafe code, don't bother with the VOP.
490 ;;;
491 (deftransform %check-bound ((array dimension index))
492 (unless (constant-continuation-p dimension)
493 (give-up))
494 (let ((dim (continuation-value dimension)))
495 `(the (integer 0 (,dim)) index)))
496 ;;;
497 (deftransform %check-bound ((array dimension index) * *
498 :policy (and (> speed safety) (= safety 0)))
499 'index)
500
501
502 ;;; WITH-ROW-MAJOR-INDEX -- internal.
503 ;;;
504 ;;; Handy macro for computing the row-major index given a set of indices. We
505 ;;; wrap each index with a call to %check-bound to assure that everything
506 ;;; works out correctly. We can wrap all the interior arith with truly-the
507 ;;; index because we know the the resultant row-major index must be an index.
508 ;;;
509 (eval-when (compile eval)
510 ;;;
511 (defmacro with-row-major-index ((array indices index &optional new-value)
512 &rest body)
513 `(let (n-indices dims)
514 (dotimes (i (length ,indices))
515 (push (make-symbol (format nil "INDEX-~D" i)) n-indices)
516 (push (make-symbol (format nil "DIM-~D" i)) dims))
517 (setf n-indices (nreverse n-indices))
518 (setf dims (nreverse dims))
519 `(lambda (,',array ,@n-indices ,@',(when new-value (list new-value)))
520 (let* (,@(let ((,index -1))
521 (mapcar #'(lambda (name)
522 `(,name (array-dimension ,',array
523 ,(incf ,index))))
524 dims))
525 (,',index
526 ,(if (null dims)
527 0
528 (do* ((dims dims (cdr dims))
529 (indices n-indices (cdr indices))
530 (last-dim nil (car dims))
531 (form `(%check-bound ,',array
532 ,(car dims)
533 ,(car indices))
534 `(truly-the index
535 (+ (truly-the index
536 (* ,form
537 ,last-dim))
538 (%check-bound
539 ,',array
540 ,(car dims)
541 ,(car indices))))))
542 ((null (cdr dims)) form)))))
543 ,',@body))))
544 ;;;
545 ); eval-when
546
547 ;;; ARRAY-ROW-MAJOR-INDEX -- transform.
548 ;;;
549 ;;; Just return the index after computing it.
550 ;;;
551 (deftransform array-row-major-index ((array &rest indices))
552 (with-row-major-index (array indices index)
553 index))
554
555
556
557 ;;;; Array accessors:
558
559 ;;; SVREF, %SVSET, SCHAR, %SCHARSET, CHAR,
560 ;;; %CHARSET, SBIT, %SBITSET, BIT, %BITSET
561 ;;; -- source transforms.
562 ;;;
563 ;;; We convert all typed array accessors into aref and %aset with type
564 ;;; assertions on the array.
565 ;;;
566 (macrolet ((frob (reffer setter type)
567 `(progn
568 (def-source-transform ,reffer (a &rest i)
569 (if (byte-compiling)
570 (values nil t)
571 `(aref (the ,',type ,a) ,@i)))
572 (def-source-transform ,setter (a &rest i)
573 (if (byte-compiling)
574 (values nil t)
575 `(%aset (the ,',type ,a) ,@i))))))
576 (frob sbit %sbitset (simple-array bit))
577 (frob bit %bitset (array bit)))
578
579 (macrolet ((frob (reffer setter type)
580 `(progn
581 (def-source-transform ,reffer (a i)
582 (if (byte-compiling)
583 (values nil t)
584 `(aref (the ,',type ,a) ,i)))
585 (def-source-transform ,setter (a i v)
586 (if (byte-compiling)
587 (values nil t)
588 `(%aset (the ,',type ,a) ,i ,v))))))
589 (frob svref %svset simple-vector)
590 (frob schar %scharset simple-string)
591 (frob char %charset string))
592
593 ;;; AREF, %ASET -- transform.
594 ;;;
595 ;;; Convert into a data-vector-ref (or set) with the set of indices replaced
596 ;;; with the an expression for the row major index.
597 ;;;
598 (deftransform aref ((array &rest indices))
599 (with-row-major-index (array indices index)
600 (data-vector-ref array index)))
601 ;;;
602 (deftransform %aset ((array &rest stuff))
603 (let ((indices (butlast stuff)))
604 (with-row-major-index (array indices index new-value)
605 (data-vector-set array index new-value))))
606
607 ;;; ROW-MAJOR-AREF, %SET-ROW-MAJOR-AREF -- transform.
608 ;;;
609 ;;; Just convert into a data-vector-ref (or set) after checking that the
610 ;;; index is inside the array total size.
611 ;;;
612 (deftransform row-major-aref ((array index))
613 `(data-vector-ref array (%check-bound array (array-total-size array) index)))
614 ;;;
615 (deftransform %set-row-major-aref ((array index new-value))
616 `(data-vector-set array
617 (%check-bound array (array-total-size array) index)
618 new-value))
619
620
621 ;;;; Bit-vector array operation canonicalization:
622 ;;;
623 ;;; We convert all bit-vector operations to have the result array specified.
624 ;;; This allows any result allocation to be open-coded, and eliminates the need
625 ;;; for any VM-dependent transforms to handle these cases.
626
627 (dolist (fun '(bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1
628 bit-andc2 bit-orc1 bit-orc2))
629 ;;
630 ;; Make a result array if result is NIL or unsupplied.
631 (deftransform fun ((bit-array-1 bit-array-2 &optional result-bit-array)
632 '(bit-vector bit-vector &optional null) '*
633 :eval-name t :policy (>= speed space))
634 `(,fun bit-array-1 bit-array-2
635 (make-array (length bit-array-1) :element-type 'bit)))
636 ;;
637 ;; If result its T, make it the first arg.
638 (deftransform fun ((bit-array-1 bit-array-2 result-bit-array)
639 '(bit-vector bit-vector (member t)) '*
640 :eval-name t)
641 `(,fun bit-array-1 bit-array-2 bit-array-1)))
642
643 ;;; Similar for BIT-NOT, but there is only one arg...
644 ;;;
645 (deftransform bit-not ((bit-array-1 &optional result-bit-array)
646 (bit-vector &optional null) *
647 :policy (>= speed space))
648 '(bit-not bit-array-1
649 (make-array (length bit-array-1) :element-type 'bit)))
650 ;;;
651 (deftransform bit-not ((bit-array-1 result-bit-array)
652 (bit-vector (constant-argument t)))
653 '(bit-not bit-array-1 bit-array-1))
654
655
656 ;;; ARRAY-HEADER-P -- transform.
657 ;;;
658 ;;; Pick off some constant cases.
659 ;;;
660 (deftransform array-header-p ((array) (array))
661 (let ((type (continuation-type array)))
662 (declare (optimize (safety 3)))
663 (unless (array-type-p type)
664 (give-up))
665 (let ((dims (array-type-dimensions type)))
666 (cond ((csubtypep type (specifier-type '(simple-array * (*))))
667 ;; No array header.
668 nil)
669 ((and (listp dims) (> (length dims) 1))
670 ;; Multi-dimensional array, will have a header.
671 t)
672 (t
673 (give-up))))))

  ViewVC Help
Powered by ViewVC 1.1.5