Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
cmucl
cmucl
Commits
d80c929a
Commit
d80c929a
authored
Nov 10, 1990
by
wlott
Browse files
Moved all the array noise into it's own file, array-tran.lisp.
parent
a76bc618
Changes
1
Hide whitespace changes
Inline
Side-by-side
compiler/srctran.lisp
View file @
d80c929a
...
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.
19
1990/1
0
/10 1
5:19:57 ram
Exp $
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.
20
1990/1
1
/10 1
8:39:00 wlott
Exp $
;;;
;;; This file contains macro-like source transformations which convert
;;; uses of certain functions into the canonical form desired within the
...
...
@@ -528,104 +528,6 @@
0
'*
))))
;;;; Array derive-type optimizers:
(
defoptimizer
(
array-in-bounds-p
derive-type
)
((
array
&rest
indices
))
(
assert-continuation-type
array
(
specifier-type
`
(
array
*
,
(
make-list
(
length
indices
)
:initial-element
'*
))))
*universal-type*
)
(
defoptimizer
(
aref
derive-type
)
((
array
&rest
indices
))
(
assert-continuation-type
array
(
specifier-type
`
(
array
*
,
(
make-list
(
length
indices
)
:initial-element
'*
))))
(
let
((
type
(
continuation-type
array
)))
(
when
(
array-type-p
type
)
(
array-type-element-type
type
))))
(
defoptimizer
(
data-vector-ref
derive-type
)
((
array
index
))
(
let
((
type
(
continuation-type
array
)))
(
when
(
array-type-p
type
)
(
array-type-element-type
type
))))
(
defoptimizer
(
%aset
derive-type
)
((
array
&rest
stuff
))
(
assert-continuation-type
array
(
specifier-type
`
(
array
*
,
(
make-list
(
1-
(
length
stuff
))
:initial-element
'*
))))
(
let
((
type
(
continuation-type
array
)))
(
when
(
array-type-p
type
)
(
let
((
val
(
car
(
last
stuff
)))
(
eltype
(
array-type-element-type
type
)))
(
assert-continuation-type
val
eltype
)
(
continuation-type
val
)))))
(
defoptimizer
(
data-vector-set
derive-type
)
((
array
index
new-value
))
(
let
((
type
(
continuation-type
array
)))
(
when
(
array-type-p
type
)
(
let
((
eltype
(
array-type-element-type
type
)))
(
assert-continuation-type
new-value
eltype
)
(
continuation-type
new-value
)))))
(
defoptimizer
(
array-row-major-index
derive-type
)
((
array
&rest
indices
))
(
assert-continuation-type
array
(
specifier-type
`
(
array
*
,
(
make-list
(
length
indices
)
:initial-element
'*
))))
*universal-type*
)
(
defoptimizer
(
row-major-aref
derive-type
)
((
array
index
))
(
let
((
type
(
continuation-type
array
)))
(
when
(
array-type-p
type
)
(
array-type-element-type
type
))))
(
defoptimizer
(
%set-row-major-aref
derive-type
)
((
array
index
new-value
))
(
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
)))))
(
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
'*
)))))
;;;; Miscellaneous derive-type methods:
...
...
@@ -1339,245 +1241,6 @@
(
give-up
))
'
(
%negate
y
))
;;;; Array accessors:
;;;
;;; We convert all array accessors into aref and %aset.
;;;
(
def-source-transform
svref
(
a
i
)
`
(
aref
(
the
simple-vector
,
a
)
,
i
))
(
def-source-transform
%svset
(
a
i
v
)
`
(
%aset
(
the
simple-vector
,
a
)
,
i
,
v
))
(
def-source-transform
schar
(
a
i
)
`
(
aref
(
the
simple-string
,
a
)
,
i
))
(
def-source-transform
%scharset
(
a
i
v
)
`
(
%aset
(
the
simple-string
,
a
)
,
i
,
v
))
(
def-source-transform
char
(
a
i
)
`
(
aref
(
the
string
,
a
)
,
i
))
(
def-source-transform
%charset
(
a
i
v
)
`
(
%aset
(
the
string
,
a
)
,
i
,
v
))
(
def-source-transform
sbit
(
a
&rest
i
)
`
(
aref
(
the
(
simple-array
bit
)
,
a
)
,@
i
))
(
def-source-transform
%sbitset
(
a
&rest
i
)
`
(
%aset
(
the
(
simple-array
bit
)
,
a
)
,@
i
))
(
def-source-transform
bit
(
a
&rest
i
)
`
(
aref
(
the
(
array
bit
)
,
a
)
,@
i
))
(
def-source-transform
%bitset
(
a
&rest
i
)
`
(
%aset
(
the
(
array
bit
)
,
a
)
,@
i
))
(
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
))))
(
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
)))
(
type
(
specifier-type
spec
)))
(
cond
((
csubtypep
type
(
specifier-type
'simple-string
))
(
when
initial-element
(
give-up
"Can't hack initial elements in strings."
))
`
(
truly-the
,
spec
(
%primitive
alloc-string
(
the
index
length
))))
((
csubtypep
type
(
specifier-type
'simple-bit-vector
))
(
unless
(
or
(
not
initial-element
)
(
and
(
constant-continuation-p
initial-element
)
(
eql
(
continuation-value
initial-element
)
0
)))
(
give-up
"Can't hack non-zero initial-elements in bit-vectors."
))
(
values
`
(
truly-the
,
spec
(
%primitive
allocate-vector
vm:simple-bit-vector-type
length
(
the
index
(
ceiling
length
vm:word-bits
))))
'
((
declare
(
type
index
length
)))))
((
csubtypep
type
(
specifier-type
'simple-vector
))
`
(
truly-the
,
spec
(
%primitive
alloc-g-vector
(
the
index
length
)
initial-element
)))
(
t
(
give-up
"Can't open-code creation of ~S."
(
type-specifier
type
))))))
;;; ### Should pass though any :INITIAL-ELEMENT to MAKE-ARRAY, but this would
;;; be a pessimization until the compiler can transform MAKE-ARRAY of strings
;;; with initial elements. Until then, it is faster to call MAKE-STRING than
;;; MAKE-ARRAY.
;;;
(
def-source-transform
make-string
(
length
)
`
(
make-array
,
length
:element-type
'base-character
))
;;; Transforms for various random array properties. If the property is know
;;; at compile time because of a type spec, use that constant value.
(
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
)
(
length
dims
)))))
(
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
)))))))
(
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
))))
(
deftransform
length
((
vector
)
(
vector
))
'
(
vector-length
vector
))
(
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
)
(
if
(
member
'*
dims
)
(
do
((
form
1
`
(
truly-the
index
(
*
(
truly-the
index
(
array-dimension
array
,
i
))
,
form
)))
(
i
0
(
1+
i
)))
((
=
i
(
length
dims
))
form
))
(
reduce
#'
*
dims
))))))
(
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."
)))))))
;;; 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
)
;;; Array accessor/setter transforms.
(
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
))))
(
deftransform
array-row-major-index
((
array
&rest
indices
))
(
with-row-major-index
(
array
indices
index
)
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
))))
(
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
))
;;;; Apply:
;;;
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment