/[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 - (hide 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 wlott 1.1 ;;; -*- Package: C; Log: C.Log -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.9 ;;; 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 rtoy 1.37 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/array-tran.lisp,v 1.37 2005/01/07 21:47:18 rtoy Exp $")
9 ram 1.9 ;;;
10 wlott 1.1 ;;; **********************************************************************
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 wlott 1.3 ;;; ASSERT-ARRAY-RANK -- internal
22 wlott 1.1 ;;;
23     ;;; Array operations that use a specific number of indices implicitly assert
24     ;;; that the array is of that rank.
25     ;;;
26 wlott 1.3 (defun assert-array-rank (array rank)
27     (assert-continuation-type
28 wlott 1.1 array
29     (specifier-type `(array * ,(make-list rank :initial-element '*)))))
30    
31     ;;; EXTRACT-ELEMENT-TYPE -- internal
32     ;;;
33 dtc 1.23 ;;; Array access functions return an object from the array, hence it's
34     ;;; type will be asserted to be array element type.
35 wlott 1.1 ;;;
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 dtc 1.23 ;;; 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 wlott 1.1 ;;; 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 dtc 1.28 (assert-continuation-optional-type new-value
62 toy 1.29 (array-type-specialized-element-type type))))
63 wlott 1.1 (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 dtc 1.23 (defoptimizer (aref derive-type) ((array &rest indices) node)
86 wlott 1.4 (assert-array-rank array (length indices))
87 dtc 1.23 ;; If the node continuation has a single use then assert its type.
88 rtoy 1.35 ;;
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 dtc 1.23 (let ((cont (node-cont node)))
103 dtc 1.25 (when (= (length (find-uses cont)) 1)
104 toy 1.29 (assert-continuation-type cont (extract-upgraded-element-type array))))
105 dtc 1.23 (extract-upgraded-element-type array))
106 wlott 1.1
107     ;;; %ASET -- derive-type optimizer.
108     ;;;
109     (defoptimizer (%aset derive-type) ((array &rest stuff))
110     (assert-array-rank array (1- (length stuff)))
111 rtoy 1.37 (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 wlott 1.1
130     ;;; DATA-VECTOR-REF -- derive-type optimizer.
131     ;;;
132     (defoptimizer (data-vector-ref derive-type) ((array index))
133 dtc 1.23 (extract-upgraded-element-type array))
134 wlott 1.1
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 ram 1.10
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 wlott 1.1
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 dtc 1.23 (extract-upgraded-element-type array))
165 wlott 1.1
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 wlott 1.11 (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 wlott 1.1
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 ram 1.16 (if (byte-compiling)
206 ram 1.15 (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 wlott 1.1
219    
220     ;;; MAKE-STRING -- source-transform.
221     ;;;
222     ;;; Just convert it into a make-array.
223     ;;;
224 gerd 1.31 (deftransform make-string ((length &key (element-type 'base-char)
225 gerd 1.30 (initial-element #\NULL)))
226     `(make-array (the (values index &rest t) length)
227     :element-type element-type
228     :initial-element initial-element))
229 wlott 1.1
230     (defconstant array-info
231 wlott 1.12 '((base-char #\NULL 8 vm:simple-string-type)
232 rtoy 1.36 (single-float 0.0f0 32 vm:simple-array-single-float-type)
233 wlott 1.1 (double-float 0.0d0 64 vm:simple-array-double-float-type)
234 dtc 1.26 #+long-float (long-float 0.0l0 #+x86 96 #+sparc 128
235     vm:simple-array-long-float-type)
236 wlott 1.1 (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 dtc 1.27 ((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 rtoy 1.36 ((complex single-float) #C(0.0f0 0.0f0) 64
247 dtc 1.27 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 dtc 1.26 ((complex long-float) #C(0.0l0 0.0l0) #+x86 192 #+sparc 256
252     vm:simple-array-complex-long-float-type)
253 wlott 1.1 (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 wlott 1.6 (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 wlott 1.1 (values
292 dtc 1.22 (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 wlott 1.1 '((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 wlott 1.6 (give-up "Dimension list contains something other than an integer: ~S"
320 wlott 1.1 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 gerd 1.32 ((:maybe *)
404 wlott 1.1 (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 ram 1.7
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 wlott 1.1 ;;; 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 wlott 1.2 (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 wlott 1.1
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 gerd 1.34 `(the (integer 0 (,dim)) index)))
496 wlott 1.1 ;;;
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 ram 1.16 (if (byte-compiling)
570 ram 1.15 (values nil t)
571     `(aref (the ,',type ,a) ,@i)))
572 wlott 1.1 (def-source-transform ,setter (a &rest i)
573 ram 1.16 (if (byte-compiling)
574 ram 1.15 (values nil t)
575     `(%aset (the ,',type ,a) ,@i))))))
576 gerd 1.33 (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 wlott 1.1 (frob svref %svset simple-vector)
590     (frob schar %scharset simple-string)
591 gerd 1.33 (frob char %charset string))
592 wlott 1.1
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 ram 1.7
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 ram 1.14 '(bit-vector bit-vector &optional null) '*
633 ram 1.7 :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 ram 1.14 '(bit-vector bit-vector (member t)) '*
640 ram 1.7 :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 ram 1.17 '(bit-not bit-array-1 bit-array-1))
654 dtc 1.20
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