Skip to content
Snippets Groups Projects
array-tran.lisp 16.3 KiB
Newer Older
wlott's avatar
wlott committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/array-tran.lisp,v 1.1 1990/11/10 18:39:33 wlott Exp $
;;;
;;; This file contains array specific optimizers and transforms.
;;; 
;;; Extracted from srctran and extended by William Lott.
;;;
(in-package "C")


;;;; Derive-Type Optimizers

;;; ASSERT-NUMBER-OF-ARGS  -- internal
;;;
;;; Array operations that use a specific number of indices implicitly assert
;;; that the array is of that rank.
;;; 
(defun assert-continuation-rank (array rank)
  (assert-array-type
   array
   (specifier-type `(array * ,(make-list rank :initial-element '*)))))
  
;;; EXTRACT-ELEMENT-TYPE  -- internal
;;;
;;; Array access functions return an object from the array, hence it's type
;;; is going to be the array element type.
;;;
(defun extract-element-type (array)
  (let ((type (continuation-type array)))
    (if (array-type-p type)
	(array-type-element-type type)
	*universal-type*)))

;;; ASSERT-NEW-VALUE-TYPE  --  internal
;;;
;;; The ``new-value'' for array setters must fit in the array, and the
;;; return type is going to be the same as the new-value for setf functions.
;;; 
(defun assert-new-value-type (new-value array)
  (let ((type (continuation-type array)))
    (when (array-type-p type)
      (assert-continuation-type new-value (array-type-element-type type))))
  (continuation-type new-value))

;;; Unsupplied-Or-NIL  --  Internal
;;;
;;;    Return true if Arg is NIL, or is a constant-continuation whose value is
;;; NIL, false otherwise.
;;;
(defun unsupplied-or-nil (arg)
  (declare (type (or continuation null) arg))
  (or (not arg)
      (and (constant-continuation-p arg)
	   (not (continuation-value arg)))))


;;; ARRAY-IN-BOUNDS-P  --  derive-type optimizer.
;;;
(defoptimizer (array-in-bounds-p derive-type) ((array &rest indices))
  (assert-array-rank array (length indices))
  *universal-type*)

;;; AREF  --  derive-type optimizer.
;;;
(defoptimizer (aref derive-type) ((array &rest indices))
  (assert-array-rank array indices)
  (extract-element-type array))

;;; %ASET  --  derive-type optimizer.
;;;
(defoptimizer (%aset derive-type) ((array &rest stuff))
  (assert-array-rank array (1- (length stuff)))
  (assert-new-value-type (car (last stuff)) array))

;;; DATA-VECTOR-REF  --  derive-type optimizer.
;;;
(defoptimizer (data-vector-ref derive-type) ((array index))
  (extract-element-type array))

;;; DATA-VECTOR-SET  --  derive-type optimizer.
;;;
(defoptimizer (data-vector-set derive-type) ((array index new-value))
  (assert-new-value-type new-value array))

;;; ARRAY-ROW-MAJOR-INDEX  --  derive-type optimizer.
;;;
(defoptimizer (array-row-major-index derive-type) ((array &rest indices))
  (assert-array-rank array (length indices))
  *universal-type*)

;;; ROW-MAJOR-AREF  --  derive-type optimizer.
;;;
(defoptimizer (row-major-aref derive-type) ((array index))
  (extract-element-type array))
  
;;; %SET-ROW-MAJOR-AREF  --  derive-type optimizer.
;;;
(defoptimizer (%set-row-major-aref derive-type) ((array index new-value))
  (assert-new-value-type new-value array))

;;; MAKE-ARRAY  --  derive-type optimizer.
;;; 
(defoptimizer (make-array derive-type)
	      ((dims &key initial-element element-type initial-contents
		adjustable fill-pointer displaced-index-offset displaced-to))
  (specifier-type
   `(,(if (and (unsupplied-or-nil adjustable)
	       (unsupplied-or-nil displaced-to)
	       (unsupplied-or-nil fill-pointer))
	  'simple-array
	  'array)
     ,(cond ((not element-type) 't)
	    ((constant-continuation-p element-type)
	     (continuation-value element-type))
	    (t
	     '*))
     ,(cond ((constant-continuation-p dims)
	     (let ((val (continuation-value dims)))
	       (if (listp val) val (list val))))
	    ((csubtypep (continuation-type dims)
			(specifier-type 'integer))
	     '(*))
	    (t
	     '*)))))


;;;; Constructors.

;;; VECTOR  --  source-transform.
;;;
;;; Convert VECTOR into a make-array followed by setfs of all the elements.
;;;
(def-source-transform vector (&rest elements)
  (let ((len (length elements))
	(n -1))
    (once-only ((n-vec `(make-array ,len)))
      `(progn 
	 ,@(mapcar #'(lambda (el)
		       (once-only ((n-val el))
			 `(locally (declare (optimize (safety 0)))
			    (setf (svref ,n-vec ,(incf n)) ,n-val))))
		   elements)
	 ,n-vec))))


;;; MAKE-STRING  --  source-transform.
;;; 
;;; Just convert it into a make-array.
;;;
(def-source-transform make-string (length &key (initial-element #\NULL))
  `(make-array ,length
	       :element-type 'base-character
	       :initial-element ',initial-element))

(defconstant array-info
  '((base-character #\NULL 8 vm:simple-string-type)
    (single-float 0.0s0 32 vm:simple-array-single-float-type)
    (double-float 0.0d0 64 vm:simple-array-double-float-type)
    (bit 0 1 vm:simple-bit-vector-type)
    ((unsigned-byte 2) 0 2 vm:simple-array-unsigned-byte-2-type)
    ((unsigned-byte 4) 0 4 vm:simple-array-unsigned-byte-4-type)
    ((unsigned-byte 8) 0 8 vm:simple-array-unsigned-byte-8-type)
    ((unsigned-byte 16) 0 16 vm:simple-array-unsigned-byte-16-type)
    ((unsigned-byte 32) 0 32 vm:simple-array-unsigned-byte-32-type)
    (t 0 32 vm:simple-vector-type)))

;;; MAKE-ARRAY  --  source-transform.
;;;
;;; The integer type restriction on the length assures that it will be a
;;; vector.  The lack of adjustable, fill-pointer, and displaced-to keywords
;;; assures that it will be simple.
;;;
(deftransform make-array ((length &key initial-element element-type)
			  (integer &rest *))
  (let* ((eltype (cond ((not element-type) t)
		       ((not (constant-continuation-p element-type))
			(give-up "Element-Type is not constant."))
		       (t
			(continuation-value element-type))))
	 (len (if (constant-continuation-p length)
		  (continuation-value length)
		  '*))
	 (spec `(simple-array ,eltype (,len)))
	 (eltype-type (specifier-type eltype)))
    (multiple-value-bind
	(default-initial-element element-size typecode)
	(dolist (info array-info
		      (give-up "Cannot open-code creation of ~S" spec))
	  (when (csubtypep eltype-type (specifier-type (car info)))
	    (return (values-list (cdr info)))))
      (let ((constructor
	     `(truly-the
	       ,spec
	       (allocate-vector
		,typecode
		length
		(truncate (+ (* ,(if (eq 'vm:simple-string-type typecode)
				     '(1+ length)
				     'length)
				,element-size)
			     (1- vm:word-bits))
			  vm:word-bits)))))
	(values
	 (if (and default-initial-element
		  (or (null initial-element)
		      (and (constant-continuation-p initial-element)
			   (eql (continuation-value initial-element)
				default-initial-element))))
	     constructor
	     `(truly-the ,spec (fill ,constructor initial-element)))
	 '((declare (type index length))))))))

;;; MAKE-ARRAY  --  transform.
;;;
;;; The list type restriction does not assure that the result will be a
;;; multi-dimensional array.  But the lack of 
;;; 
(deftransform make-array ((dims &key initial-element element-type)
			  (list &rest *))
  (unless (or (null element-type) (constant-continuation-p element-type))
    (give-up "Element-type not constant; cannot open code array creation")) 
  (unless (constant-continuation-p dims)
    (give-up "Dimension list not constant; cannot open code array creation"))
  (let ((dims (continuation-value dims)))
    (unless (every #'integerp dims)
      (give-up "Dimension list contains sometime other than an integer: ~S"
	       dims))
    (if (= (length dims) 1)
	`(make-array ',(car dims)
		     ,@(when initial-element
			 '(:initial-element initial-element))
		     ,@(when element-type
			 '(:element-type element-type)))
	(let* ((total-size (reduce #'* dims))
	       (rank (length dims))
	       (spec `(simple-array
		       ,(cond ((null element-type) t)
			      ((constant-continuation-p element-type)
			       (continuation-value element-type))
			      (t '*))
			   ,(make-list rank :initial-element '*))))
	  `(let ((header (make-array-header vm:simple-array-type ,rank)))
	     (setf (%array-fill-pointer header) ,total-size)
	     (setf (%array-fill-pointer-p header) nil)
	     (setf (%array-available-elements header) ,total-size)
	     (setf (%array-data-vector header)
		   (make-array ,total-size
			       ,@(when element-type
				   '(:element-type element-type))
			       ,@(when initial-element
				   '(:initial-element initial-element))))
	     (setf (%array-displaced-p header) nil)
	     ,@(let ((axis -1))
		 (mapcar #'(lambda (dim)
			     `(setf (%array-dimension header ,(incf axis))
				    ,dim))
			 dims))
	     (truly-the ,spec header))))))


;;;; Random properties of arrays.

;;; Transforms for various random array properties.  If the property is know
;;; at compile time because of a type spec, use that constant value.

;;; ARRAY-RANK  --  transform.
;;;
;;; If we can tell the rank from the type info, use it instead.
;;;
(deftransform array-rank ((array))
  (let ((array-type (continuation-type array)))
    (unless (array-type-p array-type)
      (give-up))
    (let ((dims (array-type-dimensions array-type)))
      (if (not (listp dims))
	  (give-up "Array rank not known at compile time: ~S" dims)
	  (length dims)))))

;;; ARRAY-DIMENSION  --  transform.
;;;
;;; If we know the dimensions at compile time, just use it.  Otherwise, if
;;; we can tell that the axis is in bounds, convert to %array-dimension
;;; (which just indirects the array header) or length (if it's simple and a
;;; vector).
;;;
(deftransform array-dimension ((array axis)
			       (array index))
  (unless (constant-continuation-p axis)
    (give-up "Axis not constant."))
  (let ((array-type (continuation-type array))
	(axis (continuation-value axis)))
    (unless (array-type-p array-type)
      (give-up))
    (let ((dims (array-type-dimensions array-type)))
      (unless (listp dims)
	(give-up
	 "Array dimensions unknown, must call array-dimension at runtime."))
      (unless (> (length dims) axis)
	(abort-transform "Array has dimensions ~S, ~D is too large."
			 dims axis))
      (let ((dim (nth axis dims)))
	(cond ((integerp dim)
	       dim)
	      ((= (length dims) 1)
	       (ecase (array-type-complexp array-type)
		 ((t)
		  '(%array-dimension array 0))
		 ((nil)
		  '(length array))
		 (*
		  (give-up "Can't tell if array is simple."))))
	      (t
	       '(%array-dimension array axis)))))))

;;; LENGTH  --  transform.
;;;
;;; If the length has been declared and it's simple, just return it.
;;;
(deftransform length ((vector)
		      ((simple-array * (*))))
  (let ((type (continuation-type vector)))
    (unless (array-type-p type)
      (give-up))
    (let ((dims (array-type-dimensions type)))
      (unless (and (listp dims) (integerp (car dims)))
	(give-up "Vector length unknown, must call length at runtime."))
      (car dims))))

;;; LENGTH  --  transform.
;;;
;;; All vectors can get their length by using vector-length.  If it's simple,
;;; it will extract the length slot from the vector.  It it's complex, it will
;;; extract the fill pointer slot from the array header.
;;;
(deftransform length ((vector) (vector))
  '(vector-length vector))

;;; ARRAY-TOTAL-SIZE  --  transform.
;;;
;;; Again, if we can tell the results from the type, just use it.  Otherwise,
;;; if we know the rank, convert into a computation based on array-dimension.
;;; We can wrap a truly-the index around the multiplications because we know
;;; that the total size must be an index.
;;; 
(deftransform array-total-size ((array)
				(array))
  (let ((array-type (continuation-type array)))
    (unless (array-type-p array-type)
      (give-up))
    (let ((dims (array-type-dimensions array-type)))
      (unless (listp dims)
	(give-up "Can't tell the rank at compile time.")
	(if (member '* dims)
	    (do ((form 1 `(truly-the index
				     (* (array-dimension array ,i) ,form)))
		 (i 0 (1+ i)))
		((= i (length dims)) form))
	    (reduce #'* dims))))))

;;; ARRAY-HAS-FILL-POINTER-P  --  transform.
;;;
;;; Only complex vectors have fill pointers.
;;;
(deftransform array-has-fill-pointer-p ((array))
  (let ((array-type (continuation-type array)))
    (unless (array-type-p array-type)
      (give-up))
    (let ((dims (array-type-dimensions array-type)))
      (if (and (listp dims) (not (= (length dims) 1)))
	  nil
	  (ecase (array-type-complexp array-type)
	    ((t)
	     t)
	    ((nil)
	     nil)
	    (*
	     (give-up "Array type ambiguous; must call ~
	              array-has-fill-pointer-p at runtime.")))))))

;;; %CHECK-BOUND  --  transform.
;;; 
;;; Primitive used to verify indicies into arrays.  If we can tell at
;;; compile-time or we are generating unsafe code, don't bother with the VOP.
;;;
(deftransform %check-bound ((array dimension index))
  (unless (constant-continuation-p dimension)
    (give-up))
  (let ((dim (continuation-value dimension)))
    `(the (integer 0 ,dim) index)))
;;;
(deftransform %check-bound ((array dimension index) * *
			    :policy (and (> speed safety) (= safety 0)))
  'index)


;;; WITH-ROW-MAJOR-INDEX  --  internal.
;;;
;;; Handy macro for computing the row-major index given a set of indices.  We
;;; wrap each index with a call to %check-bound to assure that everything
;;; works out correctly.  We can wrap all the interior arith with truly-the
;;; index because we know the the resultant row-major index must be an index.
;;; 
(eval-when (compile eval)
;;;
(defmacro with-row-major-index ((array indices index &optional new-value)
				&rest body)
  `(let (n-indices dims)
     (dotimes (i (length ,indices))
       (push (make-symbol (format nil "INDEX-~D" i)) n-indices)
       (push (make-symbol (format nil "DIM-~D" i)) dims))
     (setf n-indices (nreverse n-indices))
     (setf dims (nreverse dims))
     `(lambda (,',array ,@n-indices ,@',(when new-value (list new-value)))
	(let* (,@(let ((,index -1))
		   (mapcar #'(lambda (name)
			       `(,name (array-dimension ,',array
							,(incf ,index))))
			   dims))
	       (,',index
		,(if (null dims)
		     0
		     (do* ((dims dims (cdr dims))
			   (indices n-indices (cdr indices))
			   (last-dim nil (car dims))
			   (form `(%check-bound ,',array
						,(car dims)
						,(car indices))
				 `(truly-the index
					     (+ (truly-the index
							   (* ,form
							      ,last-dim))
						(%check-bound
						 ,',array
						 ,(car dims)
						 ,(car indices))))))
			  ((null (cdr dims)) form)))))
	  ,',@body))))
;;;
); eval-when

;;; ARRAY-ROW-MAJOR-INDEX  --  transform.
;;;
;;; Just return the index after computing it.
;;;
(deftransform array-row-major-index ((array &rest indices))
  (with-row-major-index (array indices index)
    index))



;;;; Array accessors:

;;; SVREF, %SVSET, SCHAR, %SCHARSET, CHAR,
;;; %CHARSET, SBIT, %SBITSET, BIT, %BITSET
;;;   --  source transforms.
;;;
;;; We convert all typed array accessors into aref and %aset with type
;;; assertions on the array.
;;;
(macrolet ((frob (reffer setter type)
	     `(progn
		(def-source-transform ,reffer (a &rest i)
		  `(aref (the ,',type ,a) ,@i))
		(def-source-transform ,setter (a &rest i)
		  `(%aset (the ,',type ,a) ,@i)))))
  (frob svref %svset simple-vector)
  (frob schar %scharset simple-string)
  (frob char %charset string)
  (frob sbit %sbitset (simple-array bit))
  (frob bit %bitset (array bit)))

;;; AREF, %ASET  --  transform.
;;; 
;;; Convert into a data-vector-ref (or set) with the set of indices replaced
;;; with the an expression for the row major index.
;;; 
(deftransform aref ((array &rest indices))
  (with-row-major-index (array indices index)
    (data-vector-ref array index)))
;;; 
(deftransform %aset ((array &rest stuff))
  (let ((indices (butlast stuff)))
    (with-row-major-index (array indices index new-value)
      (data-vector-set array index new-value))))

;;; ROW-MAJOR-AREF, %SET-ROW-MAJOR-AREF  --  transform.
;;;
;;; Just convert into a data-vector-ref (or set) after checking that the
;;; index is inside the array total size.
;;;
(deftransform row-major-aref ((array index))
  `(data-vector-ref array (%check-bound array (array-total-size array) index)))
;;; 
(deftransform %set-row-major-aref ((array index new-value))
  `(data-vector-set array
		    (%check-bound array (array-total-size array) index)
		    new-value))