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

  ViewVC Help
Powered by ViewVC 1.1.5