mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-14 21:32:49 -08:00
279 lines
10 KiB
Common Lisp
279 lines
10 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
|
|
;;;;
|
|
;;;; CMPARRAY. Optimizations related to arrays
|
|
|
|
;;;; Copyright (c) 2008. Juan Jose Garcia-Ripol
|
|
;;;;
|
|
;;;; This program is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Library General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 2 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; See file '../Copyright' for full details.
|
|
|
|
(in-package "COMPILER")
|
|
|
|
(defun valid-array-index-p (x)
|
|
(typep x 'ext:array-index))
|
|
|
|
;;;
|
|
;;; MAKE-ARRAY
|
|
;;;
|
|
|
|
(defun guess-array-element-type (element-type)
|
|
(if (and (setf element-type (extract-constant-value element-type))
|
|
(known-type-p element-type))
|
|
(upgraded-array-element-type element-type)
|
|
'*))
|
|
|
|
(defun guess-array-dimensions-type (orig-dimensions &aux dimensions)
|
|
(and (consp orig-dimensions)
|
|
(eq (first dimensions) 'LIST)
|
|
(let ((l (list-length orig-dimensions)))
|
|
(when (and l (< -1 l array-rank-limit))
|
|
(return-from guess-array-dimensions-type
|
|
(make-list (1- l) :initial-element '*)))))
|
|
(let ((dimensions (extract-constant-value orig-dimensions :failed)))
|
|
(cond ((eq dimensions ':failed)
|
|
'*)
|
|
((valid-array-index-p dimensions)
|
|
(list dimensions))
|
|
((and (listp dimensions)
|
|
(let ((rank (list-length dimensions)))
|
|
(or (numberp rank)
|
|
(< -1 rank array-rank-limit)
|
|
(every #'valid-array-index dimensions))))
|
|
dimensions)
|
|
(t
|
|
(cmpwarn "The first argument to MAKE-ARRAY~%~A~%is not a valid set of dimensions" orig-dimensions)
|
|
'*))))
|
|
|
|
(define-compiler-macro make-array (&whole form dimensions &key (element-type t)
|
|
(initial-element nil initial-element-supplied-p)
|
|
(initial-contents nil initial-contents-supplied-p)
|
|
adjustable fill-pointer
|
|
displaced-to (displaced-index-offset 0)
|
|
&environment env)
|
|
;; This optimization is always done unless we provide content. There
|
|
;; is no speed, debug or space reason not to do it, unless the user
|
|
;; specifies not to inline MAKE-ARRAY, but in that case the compiler
|
|
;; macro should not be used.
|
|
(let* ((dimensions-type (guess-array-dimensions-type dimensions))
|
|
(guessed-element-type (guess-array-element-type element-type)))
|
|
(unless initial-contents-supplied-p
|
|
;; If the type is known and we can assume it will not change, we
|
|
;; replace it with the upgraded form.
|
|
(unless (eq guessed-element-type '*)
|
|
(setf element-type `',guessed-element-type))
|
|
;; Now we choose between making a vector or making a general array.
|
|
;; It only saves some time, since MAKE-PURE-ARRAY will call MAKE-VECTOR
|
|
;; if a one-dimensional array is to be created.
|
|
(let ((function 'si::make-pure-array))
|
|
(when (and (listp dimensions-type)
|
|
(null (rest dimensions-type))
|
|
(integerp (first dimensions-type)))
|
|
(setf function 'si::make-vector
|
|
dimensions (first dimensions-type)))
|
|
(setf form
|
|
`(,function ,element-type ,dimensions ,adjustable ,fill-pointer
|
|
,displaced-to ,displaced-index-offset)))
|
|
;; Then we may fill the array with a given value
|
|
(when initial-element-supplied-p
|
|
(setf form `(si::fill-array-with-elt ,form ,initial-element 0 nil)))
|
|
(setf form `(the (array ,guessed-element-type ,dimensions-type)
|
|
,form))))
|
|
form)
|
|
|
|
;;;
|
|
;;; VECTOR-PUSH and VECTOR-PUSH-EXTEND
|
|
;;;
|
|
|
|
(defun expand-vector-push (whole env extend)
|
|
(declare (si::c-local))
|
|
(let* ((args (rest whole)))
|
|
(with-clean-symbols (value vector index dimension)
|
|
(unless (or (eq (first args) 'value) ; No infinite recursion
|
|
(not (policy-open-code-aref/aset)))
|
|
(setf whole
|
|
`(let* ((value ,(car args))
|
|
(vector ,(second args)))
|
|
(declare (:read-only value vector)
|
|
(optimize (safety 0)))
|
|
,@(unless (policy-assume-right-type)
|
|
`((check-vectorp vector)))
|
|
(let ((index (fill-pointer vector))
|
|
(dimension (array-total-size vector)))
|
|
(declare (fixnum index dimension)
|
|
(:read-only index dimension))
|
|
(cond ((< index dimension)
|
|
(sys::fill-pointer-set vector (the fixnum (+ 1 index)))
|
|
(sys::aset vector index value)
|
|
index)
|
|
(t ,(if extend
|
|
`(vector-push-extend value vector ,@(cddr args))
|
|
nil)))))))))
|
|
whole)
|
|
|
|
(define-compiler-macro vector-push (&whole whole &rest args &environment env)
|
|
(expand-vector-push whole env nil))
|
|
|
|
(define-compiler-macro vector-push-extend (&whole whole &rest args &environment env)
|
|
(expand-vector-push whole env t))
|
|
|
|
;;;
|
|
;;; AREF/ASET
|
|
;;;
|
|
|
|
(define-compiler-macro aref (&whole form array &rest indices &environment env)
|
|
(if (policy-open-code-aref/aset env)
|
|
(expand-aref array indices env)
|
|
form))
|
|
|
|
(defun expand-aref (array indices env)
|
|
(with-clean-symbols (%array)
|
|
`(let ((%array ,array))
|
|
(declare (:read-only %array)
|
|
(optimize (safety 0)))
|
|
(row-major-aref %array
|
|
,(expand-row-major-index '%array indices env)))))
|
|
|
|
(define-compiler-macro si::aset (&whole form array &rest indices-and-value
|
|
&environment env)
|
|
(cond ((null indices-and-value)
|
|
(cmpwarn "Too few arguments to SI::ASET form~%~4I~A"
|
|
form)
|
|
form)
|
|
((policy-open-code-aref/aset env)
|
|
(let* ((indices (butlast indices-and-value))
|
|
(value (first (last indices-and-value))))
|
|
(expand-aset array indices value env)))
|
|
(t
|
|
form)))
|
|
|
|
(defun expand-aset (array indices value env)
|
|
(ext:with-unique-names (%array)
|
|
`(let* ((,%array ,array))
|
|
(declare (:read-only ,%array)
|
|
(optimize (safety 0)))
|
|
(si::row-major-aset ,%array ,(expand-row-major-index %array indices env) ,value))))
|
|
|
|
(define-compiler-macro array-row-major-index (&whole form array &rest indices &environment env)
|
|
(if (policy-open-code-aref/aset env)
|
|
(with-clean-symbols (%array)
|
|
`(let ((%array ,array))
|
|
(declare (:read-only %array)
|
|
(optimize (safety 0)))
|
|
,(expand-row-major-index '%array indices env)))
|
|
form))
|
|
|
|
(defun expand-zero-dim-index-check (a env)
|
|
(if (policy-type-assertions env)
|
|
0
|
|
`(progn
|
|
(check-arrayp ,a)
|
|
(check-expected-rank ,a 0)
|
|
0)))
|
|
|
|
(defun expand-vector-index-check (a index env)
|
|
(flet ((expansion (a index)
|
|
`(progn
|
|
(check-vectorp ,a)
|
|
(check-vector-in-bounds ,a ,index)
|
|
,index)))
|
|
(if (policy-type-assertions env)
|
|
(if (constantp index)
|
|
(expansion a index)
|
|
(with-clean-symbols (%array-index)
|
|
`(let ((%array-index ,index))
|
|
(declare (:read-only %array-index))
|
|
,(expansion a '%array-index))))
|
|
index)))
|
|
|
|
(defun expand-row-major-index (a indices env)
|
|
(when (null indices)
|
|
(return-from expand-row-major-index
|
|
(expand-zero-dim-index-check a env)))
|
|
(when (null (rest indices))
|
|
(return-from expand-row-major-index
|
|
(expand-vector-index-check a (first indices) env)))
|
|
(let* ((expected-rank (length indices))
|
|
(check (policy-array-bounds-check env))
|
|
(dims (loop for i from 0
|
|
for index in indices
|
|
collect `(,(gentemp "DIM") (array-dimension-fast ,a ,i))))
|
|
(dim-names (mapcar #'first dims)))
|
|
(with-clean-symbols (%ndx-var %output-var %dim-var)
|
|
`(let* (,@dims
|
|
(%output-var 0))
|
|
(declare (type ext:array-index %output-var ,@dim-names)
|
|
(ignorable ,@dim-names))
|
|
,@(when (policy-type-assertions env)
|
|
`((check-arrayp ,a)
|
|
(check-expected-rank ,a ,expected-rank)))
|
|
,@(loop for i from 0
|
|
for l in indices
|
|
for index in indices
|
|
for dim-var in dim-names
|
|
when (plusp i)
|
|
collect `(setf %output-var
|
|
(the ext:array-index (* %output-var ,dim-var)))
|
|
collect `(let ((%ndx-var ,index))
|
|
(declare (ext:array-index %ndx-var))
|
|
,(and check `(check-index-in-bounds ,a %ndx-var ,dim-var))
|
|
(setf %output-var
|
|
(the ext:array-index (+ %output-var %ndx-var)))))
|
|
%output-var))))
|
|
|
|
;(trace c::expand-row-major-index c::expand-aset c::expand-aref)
|
|
|
|
(defmacro check-arrayp (a)
|
|
`(c-inline
|
|
(,a) (:object) :void
|
|
"if (ecl_unlikely(!ECL_ARRAYP(#0))) FEtype_error_array(#0);"
|
|
:one-liner nil))
|
|
|
|
(defmacro check-vectorp (v)
|
|
`(c-inline
|
|
(,v) (:object) :void
|
|
"if (ecl_unlikely(!ECL_VECTORP(#0)))
|
|
FEtype_error_vector(#0);"
|
|
:one-liner nil))
|
|
|
|
(defmacro check-expected-rank (a expected-rank)
|
|
`(c-inline
|
|
(,a ,expected-rank) (:object :fixnum) :void
|
|
"if (ecl_unlikely((#0)->array.rank != (#1)))
|
|
FEwrong_dimensions(#0,#1);"
|
|
:one-liner nil))
|
|
|
|
(defmacro check-index-in-bounds (array index limit)
|
|
`(c-inline
|
|
(,array ,index ,limit) (:object :fixnum :fixnum) :void
|
|
"if (ecl_unlikely((#1)>=(#2)))
|
|
FEwrong_index(Cnil,#0,-1,MAKE_FIXNUM(#1),#2);"
|
|
:one-liner nil))
|
|
|
|
(defmacro check-vector-in-bounds (vector index)
|
|
`(c-inline
|
|
(,vector ,index) (:object :fixnum) :void
|
|
"if (ecl_unlikely((#1)>=(#0)->vector.dim))
|
|
FEwrong_index(Cnil,#0,-1,MAKE_FIXNUM(#1),(#0)->vector.dim);"
|
|
:one-liner nil))
|
|
|
|
(defconstant +array-dimension-accessor+
|
|
'#.(loop for i from 0 below array-rank-limit
|
|
collect (format nil "(#0)->array.dims[~D]" i)))
|
|
|
|
(defun array-dimension-accessor (array n)
|
|
(let ((tails #.(apply 'vector
|
|
(loop for i from 0 below array-rank-limit
|
|
for c-code = (format nil "(#0)->array.dims[~D]" i)
|
|
collect `((:object) :fixnum ,c-code :one-liner t
|
|
:side-effects nil)))))
|
|
`(c-inline (,array) ,@(aref tails n))))
|
|
|
|
(defmacro array-dimension-fast (array n)
|
|
(if (typep n '(integer 0 #.(1- array-rank-limit)))
|
|
(array-dimension-accessor array n)
|
|
(error "In macro ARRAY-DIMENSION-FAST, the index is not a constant integer: ~A"
|
|
n)))
|