Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
519803d1
Commit
519803d1
authored
34 years ago
by
wlott
Browse files
Options
Downloads
Patches
Plain Diff
Initial revision
parent
d80c929a
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
compiler/array-tran.lisp
+505
-0
505 additions, 0 deletions
compiler/array-tran.lisp
with
505 additions
and
0 deletions
compiler/array-tran.lisp
0 → 100644
+
505
−
0
View file @
519803d1
;;; -*- 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
))
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment