Skip to content
GitLab
Explore
Sign in
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
External wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Model registry
Operate
Environments
Monitor
Incidents
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
GitLab community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
cmucl
cmucl
Commits
fb6f5f57
There was an error fetching the commit references. Please try again later.
Commit
fb6f5f57
authored
Aug 10, 2013
by
Raymond Toy
Browse files
Options
Downloads
Patches
Plain Diff
Implemeent more VOPS or make them not-implemented. Long-float support
ripped out.
parent
c7a90762
No related branches found
No related tags found
No related merge requests found
Changes
1
Show whitespace changes
Inline
Side-by-side
Showing
1 changed file
src/compiler/arm/float.lisp
+145
-1023
145 additions, 1023 deletions
src/compiler/arm/float.lisp
with
145 additions
and
1023 deletions
src/compiler/arm/float.lisp
+
145
−
1023
View file @
fb6f5f57
...
...
@@ -202,26 +202,26 @@
(
let
((
nfp
(
current-nfp-tn
vop
))
(
offset
(
*
(
tn-offset
x
)
vm:word-bytes
)))
(
let
((
value-tn
(
complex-double-double-reg-real-hi-tn
y
)))
(
inst
ld
df
value-tn
nfp
offset
))
(
inst
v
ld
r
value-tn
(
make-ea
nfp
:
offset
offset
)
))
(
let
((
value-tn
(
complex-double-double-reg-real-lo-tn
y
)))
(
inst
ld
df
value-tn
nfp
(
+
offset
(
*
2
vm:word-bytes
))))
(
inst
v
ld
r
value-tn
(
make-ea
nfp
:offset
(
+
offset
(
*
2
vm:word-bytes
))))
)
(
let
((
value-tn
(
complex-double-double-reg-imag-hi-tn
y
)))
(
inst
ld
df
value-tn
nfp
(
+
offset
(
*
4
vm:word-bytes
))))
(
inst
v
ld
r
value-tn
(
make-ea
nfp
:offset
(
+
offset
(
*
4
vm:word-bytes
))))
)
(
let
((
value-tn
(
complex-double-double-reg-imag-lo-tn
y
)))
(
inst
ld
df
value-tn
nfp
(
+
offset
(
*
6
vm:word-bytes
))))))
(
inst
v
ld
r
value-tn
(
make-ea
nfp
:offset
(
+
offset
(
*
6
vm:word-bytes
))))))
)
(
define-move-function
(
store-complex-double-double
4
)
(
vop
x
y
)
((
complex-double-double-reg
)
(
complex-double-double-stack
))
(
let
((
nfp
(
current-nfp-tn
vop
))
(
offset
(
*
(
tn-offset
y
)
vm:word-bytes
)))
(
let
((
value-tn
(
complex-double-double-reg-real-hi-tn
x
)))
(
inst
st
df
value-tn
nfp
offset
))
(
inst
v
st
r
value-tn
(
make-ea
nfp
:
offset
offset
)
))
(
let
((
value-tn
(
complex-double-double-reg-real-lo-tn
x
)))
(
inst
st
df
value-tn
nfp
(
+
offset
(
*
2
vm:word-bytes
))))
(
inst
v
st
r
value-tn
(
make-ea
nfp
:offset
(
+
offset
(
*
2
vm:word-bytes
))))
)
(
let
((
value-tn
(
complex-double-double-reg-imag-hi-tn
x
)))
(
inst
st
df
value-tn
nfp
(
+
offset
(
*
4
vm:word-bytes
))))
(
inst
v
st
r
value-tn
(
make-ea
nfp
:offset
(
+
offset
(
*
4
vm:word-bytes
))))
)
(
let
((
value-tn
(
complex-double-double-reg-imag-lo-tn
x
)))
(
inst
st
df
value-tn
nfp
(
+
offset
(
*
6
vm:word-bytes
))))))
(
inst
v
st
r
value-tn
(
make-ea
nfp
:offset
(
+
offset
(
*
6
vm:word-bytes
))))))
)
)
...
...
@@ -347,21 +347,25 @@
(
with-fixed-allocation
(
y
ndescr
vm::complex-double-double-float-type
vm::complex-double-double-float-size
))
(
let
((
real-tn
(
complex-double-double-reg-real-hi-tn
x
)))
(
inst
stdf
real-tn
y
(
-
(
*
vm::complex-double-double-float-real-hi-slot
(
inst
vstr
real-tn
(
make-ea
y
:offset
(
-
(
*
vm::complex-double-double-float-real-hi-slot
vm:word-bytes
)
vm:other-pointer-type
)))
vm:other-pointer-type
)))
)
(
let
((
real-tn
(
complex-double-double-reg-real-lo-tn
x
)))
(
inst
stdf
real-tn
y
(
-
(
*
vm::complex-double-double-float-real-lo-slot
(
inst
vstr
real-tn
(
make-ea
y
:offset
(
-
(
*
vm::complex-double-double-float-real-lo-slot
vm:word-bytes
)
vm:other-pointer-type
)))
vm:other-pointer-type
)))
)
(
let
((
imag-tn
(
complex-double-double-reg-imag-hi-tn
x
)))
(
inst
stdf
imag-tn
y
(
-
(
*
vm::complex-double-double-float-imag-hi-slot
(
inst
vstr
imag-tn
(
make-ea
y
:offset
(
-
(
*
vm::complex-double-double-float-imag-hi-slot
vm:word-bytes
)
vm:other-pointer-type
)))
vm:other-pointer-type
)))
)
(
let
((
imag-tn
(
complex-double-double-reg-imag-lo-tn
x
)))
(
inst
stdf
imag-tn
y
(
-
(
*
vm::complex-double-double-float-imag-lo-slot
(
inst
vstr
imag-tn
(
make-ea
y
:offset
(
-
(
*
vm::complex-double-double-float-imag-lo-slot
vm:word-bytes
)
vm:other-pointer-type
)))))
vm:other-pointer-type
)))))
)
;;;
#+
double-double
(
define-move-vop
move-from-complex-double-double
:move
...
...
@@ -409,17 +413,21 @@
(
:note
_N
"pointer to complex double-double float coercion"
)
(
:generator
2
(
let
((
real-tn
(
complex-double-double-reg-real-hi-tn
y
)))
(
inst
lddf
real-tn
x
(
-
(
*
complex-double-double-float-real-hi-slot
word-bytes
)
other-pointer-type
)))
(
inst
vldr
real-tn
(
make-ea
x
:offset
(
-
(
*
complex-double-double-float-real-hi-slot
word-bytes
)
other-pointer-type
))))
(
let
((
real-tn
(
complex-double-double-reg-real-lo-tn
y
)))
(
inst
lddf
real-tn
x
(
-
(
*
complex-double-double-float-real-lo-slot
word-bytes
)
other-pointer-type
)))
(
inst
vldr
real-tn
(
make-ea
x
:offset
(
-
(
*
complex-double-double-float-real-lo-slot
word-bytes
)
other-pointer-type
))))
(
let
((
imag-tn
(
complex-double-double-reg-imag-hi-tn
y
)))
(
inst
lddf
imag-tn
x
(
-
(
*
complex-double-double-float-imag-hi-slot
word-bytes
)
other-pointer-type
)))
(
inst
vldr
imag-tn
(
make-ea
x
:offset
(
-
(
*
complex-double-double-float-imag-hi-slot
word-bytes
)
other-pointer-type
))))
(
let
((
imag-tn
(
complex-double-double-reg-imag-lo-tn
y
)))
(
inst
lddf
imag-tn
x
(
-
(
*
complex-double-double-float-imag-lo-slot
word-bytes
)
other-pointer-type
)))))
(
inst
vldr
imag-tn
(
make-ea
x
:offset
(
-
(
*
complex-double-double-float-imag-lo-slot
word-bytes
)
other-pointer-type
))))))
#+
double-double
(
define-move-vop
move-to-complex-double-double
:move
(
descriptor-reg
)
(
complex-double-double-reg
))
...
...
@@ -500,13 +508,13 @@
(
complex-double-double-stack
(
let
((
offset
(
*
(
tn-offset
y
)
word-bytes
)))
(
let
((
real-tn
(
complex-double-double-reg-real-hi-tn
x
)))
(
inst
st
df
real-tn
nfp
offset
))
(
inst
v
st
r
real-tn
(
make-ea
nfp
:
offset
offset
)
))
(
let
((
real-tn
(
complex-double-double-reg-real-lo-tn
x
)))
(
inst
st
df
real-tn
nfp
(
+
offset
(
*
2
word-bytes
))))
(
inst
v
st
r
real-tn
(
make-ea
nfp
:offset
(
+
offset
(
*
2
word-bytes
))))
)
(
let
((
imag-tn
(
complex-double-double-reg-imag-hi-tn
x
)))
(
inst
st
df
imag-tn
nfp
(
+
offset
(
*
4
word-bytes
))))
(
inst
v
st
r
imag-tn
(
make-ea
nfp
:offset
(
+
offset
(
*
4
word-bytes
))))
)
(
let
((
imag-tn
(
complex-double-double-reg-imag-lo-tn
x
)))
(
inst
st
df
imag-tn
nfp
(
+
offset
(
*
6
word-bytes
)))))))))
(
inst
v
st
r
imag-tn
(
make-ea
nfp
:offset
(
+
offset
(
*
6
word-bytes
)))))))))
)
#+
double-double
(
define-move-vop
move-complex-double-double-float-argument
:move-argument
...
...
@@ -619,16 +627,7 @@
(
:save-p
:compute-only
)
(
:generator
3
(
note-this-location
vop
:internal-error
)
(
ecase
format
(
:single
(
inst
fcmps
x
y
))
(
:double
(
inst
fcmpd
x
y
))
(
:long
(
inst
fcmpq
x
y
)))
;; The SPARC V9 doesn't need an instruction between a
;; floating-point compare and a floating-point branch.
(
unless
(
backend-featurep
:sparc-v9
)
(
inst
nop
))
(
inst
fb
(
if
not-p
nope
yep
)
target
)
(
inst
nop
)))
(
not-implemented
)))
(
macrolet
((
frob
(
name
sc
ptype
)
`
(
define-vop
(
,
name
float-compare
)
...
...
@@ -636,33 +635,20 @@
(
y
:scs
(
,
sc
)))
(
:arg-types
,
ptype
,
ptype
))))
(
frob
single-float-compare
single-reg
single-float
)
(
frob
double-float-compare
double-reg
double-float
)
#+
long-float
(
frob
long-float-compare
long-reg
long-float
))
(
frob
double-float-compare
double-reg
double-float
))
(
macrolet
((
frob
(
translate
yep
nope
sname
dname
#+
long-float
lname
)
(
macrolet
((
frob
(
translate
yep
nope
sname
dname
)
`
(
progn
(
define-vop
(
,
sname
single-float-compare
)
(
:translate
,
translate
)
(
:variant
:single
,
yep
,
nope
))
(
define-vop
(
,
dname
double-float-compare
)
(
:translate
,
translate
)
(
:variant
:double
,
yep
,
nope
))
#+
long-float
(
define-vop
(
,
lname
long-float-compare
)
(
:translate
,
translate
)
(
:variant
:long
,
yep
,
nope
)))))
(
:variant
:double
,
yep
,
nope
)))))
(
frob
<
:l
:ge
</single-float
</double-float
#+
long-float
</long-float
)
(
frob
>
:g
:le
>/single-float
>/double-float
#+
long-float
>/long-float
)
(
frob
=
:eq
:ne
eql/single-float
eql/double-float
#+
long-float
eql/long-float
))
#+
long-float
(
deftransform
eql
((
x
y
)
(
long-float
long-float
))
'
(
and
(
=
(
long-float-low-bits
x
)
(
long-float-low-bits
y
))
(
=
(
long-float-mid-bits
x
)
(
long-float-mid-bits
y
))
(
=
(
long-float-high-bits
x
)
(
long-float-high-bits
y
))
(
=
(
long-float-exp-bits
x
)
(
long-float-exp-bits
y
))))
#+
double-double
(
deftransform
eql
((
x
y
)
(
double-double-float
double-double-float
))
'
(
and
(
eql
(
double-double-hi
x
)
(
double-double-hi
y
))
...
...
@@ -684,45 +670,6 @@
(
frob
%%single-float
single-float
)
(
frob
%%double-float
double-float
))
;; Sparc doesn't have an instruction to convert a 32-bit unsigned
;; integer to a float, but does have one for a 32-bit signed integer.
;; What we do here is break up the 32-bit number into 2 smaller
;; pieces. Each of these are converted to a float, and the higher
;; order piece is scaled appropriately, and finally everything is
;; summed together. The pieces are done in a way such that no
;; roundoff occurs. The scaling should not produce any roundoff
;; either, since the scale factor is an exact power of two. The final
;; sum will produce the correct rounded result. (I think,)
;;
;; But need to be careful because we still want to call the VOP for
;; the small pieces, so we need the transform to give up if it's known
;; that the argument is smaller than a 32-bit unsigned integer.
(
macrolet
((
frob
(
name
vop-trans
limit
unit
)
`
(
progn
(
deftransform
,
name
((
n
)
((
unsigned-byte
32
)))
;; Should this be extended to a (unsigned-byte 53)? We could. Just
;; take the low 31 bits, and the rest, and float them and combine
;; them as before.
(
when
(
csubtypep
(
c::continuation-type
n
)
(
c::specifier-type
'
(
unsigned-byte
31
)))
;; We want to give-up if we know the number can't have the
;; MSB set. The signed 32-bit vop can handle that.
(
c::give-up
))
`
(
+
(
,
',vop-trans
(
ldb
(
byte
,
',limit
0
)
n
))
(
*
(
,
',vop-trans
(
ldb
(
byte
,
',
(
-
32
limit
)
,
',limit
)
n
))
(
scale-float
,
',unit
,
',limit
))))
;; Always convert %foo to %%foo for 32-bit signed values.
(
deftransform
,
name
((
n
)
((
signed-byte
32
)))
`
(
,
',vop-trans
n
)))))
;; If we break up the numbers into the low 12 bits and the high 20
;; bits, we can use a single AND instruction to get the low 12 bits.
;; This is a microoptimization for Sparc. Otherwise, the only
;; constraint is that the pieces must be small enough to fit in the
;; desired float format without rounding.
(
frob
%single-float
%%single-float
12
1f0
)
(
frob
%double-float
%%double-float
12
1f0
))
(
macrolet
((
frob
(
name
translate
inst
to-sc
to-type
)
`
(
define-vop
(
,
name
)
(
:args
(
x
:scs
(
signed-reg
)
:target
stack-temp
...
...
@@ -738,58 +685,9 @@
(
:vop-var
vop
)
(
:save-p
:compute-only
)
(
:generator
5
(
let
((
stack-tn
(
sc-case
x
(
signed-reg
(
inst
st
x
(
current-nfp-tn
vop
)
(
*
(
tn-offset
temp
)
vm:word-bytes
))
stack-temp
)
(
signed-stack
x
))))
(
inst
ldf
temp
(
current-nfp-tn
vop
)
(
*
(
tn-offset
stack-tn
)
vm:word-bytes
))
(
note-this-location
vop
:internal-error
)
(
inst
,
inst
y
temp
))))))
(
not-implemented
)))))
(
frob
%single-float/signed
%%single-float
fitos
single-reg
single-float
)
(
frob
%double-float/signed
%%double-float
fitod
double-reg
double-float
)
#+
long-float
(
frob
%long-float/signed
%long-float
fitoq
long-reg
long-float
))
;; Sparc doesn't have an instruction to convert a 32-bit unsigned
;; integer to a float, but does have one for a 32-bit signed integer.
;; What we do here is break up the 32-bit number into 2 smaller
;; pieces. Each of these are converted to a float, and the higher
;; order piece is scaled appropriately, and finally everything is
;; summed together. The pieces are done in a way such that no
;; roundoff occurs. The scaling should not produce any roundoff
;; either, since the scale factor is an exact power of two. The final
;; sum will produce the correct rounded result. (I think,)
;;
;; But need to be careful because we still want to call the VOP for
;; the small pieces, so we need the transform to give up if it's known
;; that the argument is smaller than a 32-bit unsigned integer.
(
macrolet
((
frob
(
name
limit
unit
)
`
(
deftransform
,
name
((
n
)
((
unsigned-byte
32
)))
;; Should this be extended to a (unsigned-byte 53)? We could. Just
;; take the low 31 bits, and the rest, and float them and combine
;; them as before.
(
when
(
csubtypep
(
c::continuation-type
n
)
(
c::specifier-type
'
(
unsigned-byte
31
)))
;; We want to give-up if we know the number can't have the
;; MSB set. The signed 32-bit vop can handle that.
(
c::give-up
))
`
(
+
(
,
',name
(
ldb
(
byte
,
',limit
0
)
n
))
(
*
(
,
',name
(
ldb
(
byte
,
',
(
-
32
limit
)
,
',limit
)
n
))
(
scale-float
,
',unit
,
',limit
))))))
;; If we break up the numbers into the low 12 bits and the high 20
;; bits, we can use a single AND instruction to get the low 12 bits.
;; This is a microoptimization for Sparc. Otherwise, the only
;; constraint is that the pieces must be small enough to fit in the
;; desired float format without rounding.
(
frob
%single-float
12
1f0
)
(
frob
%double-float
12
1f0
))
(
frob
%double-float/signed
%%double-float
fitod
double-reg
double-float
))
(
macrolet
((
frob
(
name
translate
inst
from-sc
from-type
to-sc
to-type
)
`
(
define-vop
(
,
name
)
...
...
@@ -805,22 +703,10 @@
(
:generator
2
(
note-this-location
vop
:internal-error
)
(
inst
,
inst
y
x
)))))
(
frob
%single-float/double-float
%single-float
fdtos
(
frob
%single-float/double-float
%single-float
vcvt.f32.f64
double-reg
double-float
single-reg
single-float
)
#+
long-float
(
frob
%single-float/long-float
%single-float
fqtos
long-reg
long-float
single-reg
single-float
)
(
frob
%double-float/single-float
%double-float
fstod
single-reg
single-float
double-reg
double-float
)
#+
long-float
(
frob
%double-float/long-float
%double-float
fqtod
long-reg
long-float
double-reg
double-float
)
#+
long-float
(
frob
%long-float/single-float
%long-float
fstoq
single-reg
single-float
long-reg
long-float
)
#+
long-float
(
frob
%long-float/double-float
%long-float
fdtoq
double-reg
double-float
long-reg
long-float
))
(
frob
%double-float/single-float
%double-float
vcvt.f64.f32
single-reg
single-float
double-reg
double-float
))
(
macrolet
((
frob
(
trans
from-sc
from-type
inst
)
`
(
define-vop
(
,
(
symbolicate
trans
"/"
from-type
))
...
...
@@ -838,24 +724,9 @@
(
:save-p
:compute-only
)
(
:generator
5
(
note-this-location
vop
:internal-error
)
(
inst
,
inst
temp
x
)
(
sc-case
y
(
signed-stack
(
inst
stf
temp
(
current-nfp-tn
vop
)
(
*
(
tn-offset
y
)
vm:word-bytes
)))
(
signed-reg
(
inst
stf
temp
(
current-nfp-tn
vop
)
(
*
(
tn-offset
stack-temp
)
vm:word-bytes
))
(
inst
ldsw
y
(
current-nfp-tn
vop
)
(
*
(
tn-offset
stack-temp
)
vm:word-bytes
))))))))
(
not-implemented
)))))
(
frob
%unary-truncate
single-reg
single-float
fstoi
)
(
frob
%unary-truncate
double-reg
double-float
fdtoi
)
#+
long-float
(
frob
%unary-truncate
long-reg
long-float
fqtoi
)
#-
sun4
(
frob
%unary-round
single-reg
single-float
fstoir
)
#-
sun4
(
frob
%unary-round
double-reg
double-float
fdtoir
))
(
frob
%unary-truncate
double-reg
double-float
fdtoi
))
(
define-vop
(
fast-unary-ftruncate/single-float
)
(
:args
(
x
:scs
(
single-reg
)))
...
...
@@ -867,8 +738,8 @@
(
:guard
(
not
(
backend-featurep
:sparc-v9
)))
(
:note
_N
"inline ftruncate"
)
(
:generator
2
(
inst
fstoi
r
x
)
(
inst
fitos
r
r
)))
(
inst
vcvt.s32.f32
r
x
)
(
inst
vcvt.f32.s32
r
r
)))
(
define-vop
(
fast-unary-ftruncate/double-float
)
(
:args
(
x
:scs
(
double-reg
)
:target
r
))
...
...
@@ -880,48 +751,8 @@
(
:guard
(
not
(
backend-featurep
:sparc-v9
)))
(
:note
_N
"inline ftruncate"
)
(
:generator
2
(
inst
fdtoi
r
x
)
(
inst
fitod
r
r
)))
;; The V9 architecture can convert 64-bit integers.
(
define-vop
(
v9-fast-unary-ftruncate/single-float
)
(
:args
(
x
:scs
(
single-reg
)))
(
:arg-types
single-float
)
(
:results
(
r
:scs
(
single-reg
)))
(
:result-types
single-float
)
(
:temporary
(
:scs
(
double-reg
))
temp
)
(
:policy
:fast-safe
)
(
:translate
c::fast-unary-ftruncate
)
(
:guard
(
backend-featurep
:sparc-v9
))
(
:note
_N
"inline ftruncate"
)
(
:generator
2
(
inst
fstox
temp
x
)
(
inst
fxtos
r
temp
)))
(
define-vop
(
v9-fast-unary-ftruncate/double-float
)
(
:args
(
x
:scs
(
double-reg
)
:target
r
))
(
:arg-types
double-float
)
(
:results
(
r
:scs
(
double-reg
)))
(
:result-types
double-float
)
(
:policy
:fast-safe
)
(
:translate
c::fast-unary-ftruncate
)
(
:guard
(
backend-featurep
:sparc-v9
))
(
:note
_N
"inline ftruncate"
)
(
:generator
2
(
inst
fdtox
r
x
)
(
inst
fxtod
r
r
)))
#+
sun4
(
deftransform
%unary-round
((
x
)
(
float
)
(
signed-byte
32
))
'
(
let*
((
trunc
(
truly-the
(
signed-byte
32
)
(
%unary-truncate
x
)))
(
extra
(
-
x
trunc
))
(
absx
(
abs
extra
))
(
one-half
(
float
1/2
x
)))
(
if
(
if
(
oddp
trunc
)
(
>=
absx
one-half
)
(
>
absx
one-half
))
(
truly-the
(
signed-byte
32
)
(
%unary-truncate
(
+
x
extra
)))
trunc
)))
(
inst
vcvt.s32.f64
r
x
)
(
inst
vcvt.f64.s32
r
r
)))
(
define-vop
(
make-single-float
)
(
:args
(
bits
:scs
(
signed-reg
)
:target
res
...
...
@@ -936,28 +767,7 @@
(
:policy
:fast-safe
)
(
:vop-var
vop
)
(
:generator
4
(
sc-case
bits
(
signed-reg
(
sc-case
res
(
single-reg
(
inst
st
bits
(
current-nfp-tn
vop
)
(
*
(
tn-offset
stack-temp
)
vm:word-bytes
))
(
inst
ldf
res
(
current-nfp-tn
vop
)
(
*
(
tn-offset
stack-temp
)
vm:word-bytes
)))
(
single-stack
(
inst
st
bits
(
current-nfp-tn
vop
)
(
*
(
tn-offset
res
)
vm:word-bytes
)))))
(
signed-stack
(
sc-case
res
(
single-reg
(
inst
ldf
res
(
current-nfp-tn
vop
)
(
*
(
tn-offset
bits
)
vm:word-bytes
)))
(
single-stack
(
unless
(
location=
bits
res
)
(
inst
ldsw
temp
(
current-nfp-tn
vop
)
(
*
(
tn-offset
bits
)
vm:word-bytes
))
(
inst
st
temp
(
current-nfp-tn
vop
)
(
*
(
tn-offset
res
)
vm:word-bytes
)))))))))
(
not-implemented
)))
(
define-vop
(
make-double-float
)
(
:args
(
hi-bits
:scs
(
signed-reg
))
...
...
@@ -971,46 +781,8 @@
(
:policy
:fast-safe
)
(
:vop-var
vop
)
(
:generator
2
(
let
((
stack-tn
(
sc-case
res
(
double-stack
res
)
(
double-reg
temp
))))
(
inst
st
hi-bits
(
current-nfp-tn
vop
)
(
*
(
tn-offset
stack-tn
)
vm:word-bytes
))
(
inst
st
lo-bits
(
current-nfp-tn
vop
)
(
*
(
1+
(
tn-offset
stack-tn
))
vm:word-bytes
)))
(
when
(
sc-is
res
double-reg
)
(
inst
lddf
res
(
current-nfp-tn
vop
)
(
*
(
tn-offset
temp
)
vm:word-bytes
)))))
#+
long-float
(
define-vop
(
make-long-float
)
(
:args
(
hi-bits
:scs
(
signed-reg
))
(
lo1-bits
:scs
(
unsigned-reg
))
(
lo2-bits
:scs
(
unsigned-reg
))
(
lo3-bits
:scs
(
unsigned-reg
)))
(
:results
(
res
:scs
(
long-reg
)
:load-if
(
not
(
sc-is
res
long-stack
))))
(
:temporary
(
:scs
(
long-stack
))
temp
)
(
:arg-types
signed-num
unsigned-num
unsigned-num
unsigned-num
)
(
:result-types
long-float
)
(
:translate
make-long-float
)
(
:policy
:fast-safe
)
(
:vop-var
vop
)
(
:generator
2
(
let
((
stack-tn
(
sc-case
res
(
long-stack
res
)
(
long-reg
temp
))))
(
inst
st
hi-bits
(
current-nfp-tn
vop
)
(
*
(
tn-offset
stack-tn
)
vm:word-bytes
))
(
inst
st
lo1-bits
(
current-nfp-tn
vop
)
(
*
(
1+
(
tn-offset
stack-tn
))
vm:word-bytes
))
(
inst
st
lo2-bits
(
current-nfp-tn
vop
)
(
*
(
+
2
(
tn-offset
stack-tn
))
vm:word-bytes
))
(
inst
st
lo3-bits
(
current-nfp-tn
vop
)
(
*
(
+
3
(
tn-offset
stack-tn
))
vm:word-bytes
)))
(
when
(
sc-is
res
long-reg
)
(
load-long-reg
res
(
current-nfp-tn
vop
)
(
*
(
tn-offset
temp
)
vm:word-bytes
)))))
(
not-implemented
)))
(
define-vop
(
single-float-bits
)
(
:args
(
float
:scs
(
single-reg
descriptor-reg
)
...
...
@@ -1025,25 +797,7 @@
(
:policy
:fast-safe
)
(
:vop-var
vop
)
(
:generator
4
(
sc-case
bits
(
signed-reg
(
sc-case
float
(
single-reg
(
inst
stf
float
(
current-nfp-tn
vop
)
(
*
(
tn-offset
stack-temp
)
vm:word-bytes
))
(
inst
ldsw
bits
(
current-nfp-tn
vop
)
(
*
(
tn-offset
stack-temp
)
vm:word-bytes
)))
(
single-stack
(
inst
ldsw
bits
(
current-nfp-tn
vop
)
(
*
(
tn-offset
float
)
vm:word-bytes
)))
(
descriptor-reg
(
loadw
bits
float
vm:single-float-value-slot
vm:other-pointer-type
))))
(
signed-stack
(
sc-case
float
(
single-reg
(
inst
stf
float
(
current-nfp-tn
vop
)
(
*
(
tn-offset
bits
)
vm:word-bytes
))))))))
(
not-implemented
)))
(
define-vop
(
double-float-high-bits
)
(
:args
(
float
:scs
(
double-reg
descriptor-reg
)
...
...
@@ -1056,18 +810,7 @@
(
:policy
:fast-safe
)
(
:vop-var
vop
)
(
:generator
5
(
sc-case
float
(
double-reg
(
inst
stdf
float
(
current-nfp-tn
vop
)
(
*
(
tn-offset
stack-temp
)
vm:word-bytes
))
(
inst
ldsw
hi-bits
(
current-nfp-tn
vop
)
(
*
(
tn-offset
stack-temp
)
vm:word-bytes
)))
(
double-stack
(
inst
ldsw
hi-bits
(
current-nfp-tn
vop
)
(
*
(
tn-offset
float
)
vm:word-bytes
)))
(
descriptor-reg
(
loadw
hi-bits
float
vm:double-float-value-slot
vm:other-pointer-type
)))))
(
not-implemented
)))
(
define-vop
(
double-float-low-bits
)
(
:args
(
float
:scs
(
double-reg
descriptor-reg
)
...
...
@@ -1080,18 +823,7 @@
(
:policy
:fast-safe
)
(
:vop-var
vop
)
(
:generator
5
(
sc-case
float
(
double-reg
(
inst
stdf
float
(
current-nfp-tn
vop
)
(
*
(
tn-offset
stack-temp
)
vm:word-bytes
))
(
inst
ldsw
lo-bits
(
current-nfp-tn
vop
)
(
*
(
1+
(
tn-offset
stack-temp
))
vm:word-bytes
)))
(
double-stack
(
inst
ldsw
lo-bits
(
current-nfp-tn
vop
)
(
*
(
1+
(
tn-offset
float
))
vm:word-bytes
)))
(
descriptor-reg
(
loadw
lo-bits
float
(
1+
vm:double-float-value-slot
)
vm:other-pointer-type
)))))
(
not-implemented
)))
(
define-vop
(
double-float-bits
)
(
:args
(
float
:scs
(
double-reg
descriptor-reg
)
...
...
@@ -1105,136 +837,7 @@
(
:policy
:fast-safe
)
(
:vop-var
vop
)
(
:generator
5
(
sc-case
float
(
double-reg
(
inst
stdf
float
(
current-nfp-tn
vop
)
(
*
(
tn-offset
stack-temp
)
vm:word-bytes
))
(
inst
ldsw
hi-bits
(
current-nfp-tn
vop
)
(
*
(
tn-offset
stack-temp
)
vm:word-bytes
))
(
inst
ld
lo-bits
(
current-nfp-tn
vop
)
(
*
(
1+
(
tn-offset
stack-temp
))
vm:word-bytes
)))
(
double-stack
(
inst
ldsw
hi-bits
(
current-nfp-tn
vop
)
(
*
(
tn-offset
float
)
vm:word-bytes
))
(
inst
ld
lo-bits
(
current-nfp-tn
vop
)
(
*
(
1+
(
tn-offset
float
))
vm:word-bytes
)))
(
descriptor-reg
(
loadw
hi-bits
float
vm:double-float-value-slot
vm:other-pointer-type
)
(
loadw
lo-bits
float
(
1+
vm:double-float-value-slot
)
vm:other-pointer-type
)))))
#+
long-float
(
define-vop
(
long-float-exp-bits
)
(
:args
(
float
:scs
(
long-reg
descriptor-reg
)
:load-if
(
not
(
sc-is
float
long-stack
))))
(
:results
(
exp-bits
:scs
(
signed-reg
)))
(
:temporary
(
:scs
(
double-stack
))
stack-temp
)
(
:arg-types
long-float
)
(
:result-types
signed-num
)
(
:translate
long-float-exp-bits
)
(
:policy
:fast-safe
)
(
:vop-var
vop
)
(
:generator
5
(
sc-case
float
(
long-reg
(
let
((
float
(
make-random-tn
:kind
:normal
:sc
(
sc-or-lose
'double-reg
*backend*
)
:offset
(
tn-offset
float
))))
(
inst
stdf
float
(
current-nfp-tn
vop
)
(
*
(
tn-offset
stack-temp
)
vm:word-bytes
)))
(
inst
ld
exp-bits
(
current-nfp-tn
vop
)
(
*
(
tn-offset
stack-temp
)
vm:word-bytes
)))
(
long-stack
(
inst
ld
exp-bits
(
current-nfp-tn
vop
)
(
*
(
tn-offset
float
)
vm:word-bytes
)))
(
descriptor-reg
(
loadw
exp-bits
float
vm:long-float-value-slot
vm:other-pointer-type
)))))
#+
long-float
(
define-vop
(
long-float-high-bits
)
(
:args
(
float
:scs
(
long-reg
descriptor-reg
)
:load-if
(
not
(
sc-is
float
long-stack
))))
(
:results
(
high-bits
:scs
(
unsigned-reg
)))
(
:temporary
(
:scs
(
double-stack
))
stack-temp
)
(
:arg-types
long-float
)
(
:result-types
unsigned-num
)
(
:translate
long-float-high-bits
)
(
:policy
:fast-safe
)
(
:vop-var
vop
)
(
:generator
5
(
sc-case
float
(
long-reg
(
let
((
float
(
make-random-tn
:kind
:normal
:sc
(
sc-or-lose
'double-reg
*backend*
)
:offset
(
tn-offset
float
))))
(
inst
stdf
float
(
current-nfp-tn
vop
)
(
*
(
tn-offset
stack-temp
)
vm:word-bytes
)))
(
inst
ld
high-bits
(
current-nfp-tn
vop
)
(
*
(
1+
(
tn-offset
stack-temp
))
vm:word-bytes
)))
(
long-stack
(
inst
ld
high-bits
(
current-nfp-tn
vop
)
(
*
(
1+
(
tn-offset
float
))
vm:word-bytes
)))
(
descriptor-reg
(
loadw
high-bits
float
(
1+
vm:long-float-value-slot
)
vm:other-pointer-type
)))))
#+
long-float
(
define-vop
(
long-float-mid-bits
)
(
:args
(
float
:scs
(
long-reg
descriptor-reg
)
:load-if
(
not
(
sc-is
float
long-stack
))))
(
:results
(
mid-bits
:scs
(
unsigned-reg
)))
(
:temporary
(
:scs
(
double-stack
))
stack-temp
)
(
:arg-types
long-float
)
(
:result-types
unsigned-num
)
(
:translate
long-float-mid-bits
)
(
:policy
:fast-safe
)
(
:vop-var
vop
)
(
:generator
5
(
sc-case
float
(
long-reg
(
let
((
float
(
make-random-tn
:kind
:normal
:sc
(
sc-or-lose
'double-reg
*backend*
)
:offset
(
+
2
(
tn-offset
float
)))))
(
inst
stdf
float
(
current-nfp-tn
vop
)
(
*
(
tn-offset
stack-temp
)
vm:word-bytes
)))
(
inst
ld
mid-bits
(
current-nfp-tn
vop
)
(
*
(
tn-offset
stack-temp
)
vm:word-bytes
)))
(
long-stack
(
inst
ld
mid-bits
(
current-nfp-tn
vop
)
(
*
(
+
2
(
tn-offset
float
))
vm:word-bytes
)))
(
descriptor-reg
(
loadw
mid-bits
float
(
+
2
vm:long-float-value-slot
)
vm:other-pointer-type
)))))
#+
long-float
(
define-vop
(
long-float-low-bits
)
(
:args
(
float
:scs
(
long-reg
descriptor-reg
)
:load-if
(
not
(
sc-is
float
long-stack
))))
(
:results
(
lo-bits
:scs
(
unsigned-reg
)))
(
:temporary
(
:scs
(
double-stack
))
stack-temp
)
(
:arg-types
long-float
)
(
:result-types
unsigned-num
)
(
:translate
long-float-low-bits
)
(
:policy
:fast-safe
)
(
:vop-var
vop
)
(
:generator
5
(
sc-case
float
(
long-reg
(
let
((
float
(
make-random-tn
:kind
:normal
:sc
(
sc-or-lose
'double-reg
*backend*
)
:offset
(
+
2
(
tn-offset
float
)))))
(
inst
stdf
float
(
current-nfp-tn
vop
)
(
*
(
tn-offset
stack-temp
)
vm:word-bytes
)))
(
inst
ld
lo-bits
(
current-nfp-tn
vop
)
(
*
(
1+
(
tn-offset
stack-temp
))
vm:word-bytes
)))
(
long-stack
(
inst
ld
lo-bits
(
current-nfp-tn
vop
)
(
*
(
+
3
(
tn-offset
float
))
vm:word-bytes
)))
(
descriptor-reg
(
loadw
lo-bits
float
(
+
3
vm:long-float-value-slot
)
vm:other-pointer-type
)))))
(
not-implemented
)))
;;;; Float mode hackery:
...
...
@@ -1252,28 +855,7 @@
(
:vop-var
vop
)
(
:temporary
(
:sc
unsigned-stack
)
temp
)
(
:generator
3
(
let
((
nfp
(
current-nfp-tn
vop
)))
(
inst
stfsr
nfp
(
*
word-bytes
(
tn-offset
temp
)))
(
loadw
res
nfp
(
tn-offset
temp
))
(
inst
nop
))))
#+
nil
(
define-vop
(
floating-point-modes
)
(
:results
(
res
:scs
(
unsigned-reg
)))
(
:result-types
unsigned-num
)
(
:translate
floating-point-modes
)
(
:policy
:fast-safe
)
(
:vop-var
vop
)
(
:temporary
(
:sc
double-stack
)
temp
)
(
:generator
3
(
let*
((
nfp
(
current-nfp-tn
vop
))
(
offset
(
*
4
(
tn-offset
temp
))))
(
inst
stxfsr
nfp
offset
)
;; The desired FP mode data is in the least significant 32
;; bits, which is stored at the next higher word in memory.
(
loadw
res
nfp
(
+
offset
4
))
;; Is this nop needed? (toy@rtp.ericsson.se)
(
inst
nop
))))
(
not-implemented
)))
(
define-vop
(
set-floating-point-modes
)
(
:args
(
new
:scs
(
unsigned-reg
)
:target
res
))
...
...
@@ -1285,61 +867,8 @@
(
:temporary
(
:sc
unsigned-stack
)
temp
)
(
:vop-var
vop
)
(
:generator
3
(
let
((
nfp
(
current-nfp-tn
vop
)))
(
storew
new
nfp
(
tn-offset
temp
))
(
inst
ldfsr
nfp
(
*
word-bytes
(
tn-offset
temp
)))
(
move
res
new
))))
(
not-implemented
)))
#+
nil
(
define-vop
(
set-floating-point-modes
)
(
:args
(
new
:scs
(
unsigned-reg
)
:target
res
))
(
:results
(
res
:scs
(
unsigned-reg
)))
(
:arg-types
unsigned-num
)
(
:result-types
unsigned-num
)
(
:translate
(
setf
floating-point-modes
))
(
:policy
:fast-safe
)
(
:temporary
(
:sc
double-stack
)
temp
)
(
:temporary
(
:sc
unsigned-reg
)
my-fsr
)
(
:vop-var
vop
)
(
:generator
3
(
let
((
nfp
(
current-nfp-tn
vop
))
(
offset
(
*
word-bytes
(
tn-offset
temp
))))
(
pseudo-atomic
()
;; Get the current FSR, so we can get the new %fcc's
(
inst
stxfsr
nfp
offset
)
(
inst
ldx
my-fsr
nfp
offset
)
;; Carefully merge in the new mode bits with the rest of the
;; FSR. This is only needed if we care about preserving the
;; high 32 bits of the FSR, which contain the additional
;; %fcc's on the sparc V9. If not, we don't need this, but we
;; do need to make sure that the unused bits are written as
;; zeroes, according the the V9 architecture manual.
(
inst
signx
new
)
(
inst
srlx
my-fsr
32
)
(
inst
sllx
my-fsr
32
)
(
inst
or
my-fsr
new
)
;; Save it back and load it into the fsr register
(
inst
stx
my-fsr
nfp
offset
)
(
inst
ldxfsr
nfp
offset
)
(
move
res
new
)))))
#+
nil
(
define-vop
(
set-floating-point-modes
)
(
:args
(
new
:scs
(
unsigned-reg
)
:target
res
))
(
:results
(
res
:scs
(
unsigned-reg
)))
(
:arg-types
unsigned-num
)
(
:result-types
unsigned-num
)
(
:translate
(
setf
floating-point-modes
))
(
:policy
:fast-safe
)
(
:temporary
(
:sc
double-stack
)
temp
)
(
:temporary
(
:sc
unsigned-reg
)
my-fsr
)
(
:vop-var
vop
)
(
:generator
3
(
let
((
nfp
(
current-nfp-tn
vop
))
(
offset
(
*
word-bytes
(
tn-offset
temp
))))
(
inst
stx
new
nfp
offset
)
(
inst
ldxfsr
nfp
offset
)
(
move
res
new
))))
;;;; Special functions.
...
...
@@ -1360,22 +889,7 @@
(
:save-p
:compute-only
)
(
:generator
1
(
note-this-location
vop
:internal-error
)
(
inst
fsqrtd
y
x
)))
#+
long-float
(
define-vop
(
fsqrt-long
)
(
:args
(
x
:scs
(
long-reg
)))
(
:results
(
y
:scs
(
long-reg
)))
(
:translate
%sqrt
)
(
:policy
:fast-safe
)
(
:arg-types
long-float
)
(
:result-types
long-float
)
(
:note
_N
"inline float arithmetic"
)
(
:vop-var
vop
)
(
:save-p
:compute-only
)
(
:generator
1
(
note-this-location
vop
:internal-error
)
(
inst
fsqrtq
y
x
)))
(
inst
vsqrt
y
x
)))
;;;; Complex float VOPs
...
...
@@ -1393,20 +907,7 @@
(
:policy
:fast-safe
)
(
:vop-var
vop
)
(
:generator
5
(
sc-case
r
(
complex-single-reg
(
let
((
r-real
(
complex-single-reg-real-tn
r
)))
(
unless
(
location=
real
r-real
)
(
inst
fmovs
r-real
real
)))
(
let
((
r-imag
(
complex-single-reg-imag-tn
r
)))
(
unless
(
location=
imag
r-imag
)
(
inst
fmovs
r-imag
imag
))))
(
complex-single-stack
(
let
((
nfp
(
current-nfp-tn
vop
))
(
offset
(
*
(
tn-offset
r
)
vm:word-bytes
)))
(
unless
(
location=
real
r
)
(
inst
stf
real
nfp
offset
))
(
inst
stf
imag
nfp
(
+
offset
vm:word-bytes
)))))))
(
not-implemented
)))
(
define-vop
(
make-complex-double-float
)
(
:translate
complex
)
...
...
@@ -1421,49 +922,7 @@
(
:policy
:fast-safe
)
(
:vop-var
vop
)
(
:generator
5
(
sc-case
r
(
complex-double-reg
(
let
((
r-real
(
complex-double-reg-real-tn
r
)))
(
unless
(
location=
real
r-real
)
(
move-double-reg
r-real
real
)))
(
let
((
r-imag
(
complex-double-reg-imag-tn
r
)))
(
unless
(
location=
imag
r-imag
)
(
move-double-reg
r-imag
imag
))))
(
complex-double-stack
(
let
((
nfp
(
current-nfp-tn
vop
))
(
offset
(
*
(
tn-offset
r
)
vm:word-bytes
)))
(
unless
(
location=
real
r
)
(
inst
stdf
real
nfp
offset
))
(
inst
stdf
imag
nfp
(
+
offset
(
*
2
vm:word-bytes
))))))))
#+
long-float
(
define-vop
(
make-complex-long-float
)
(
:translate
complex
)
(
:args
(
real
:scs
(
long-reg
)
:target
r
:load-if
(
not
(
location=
real
r
)))
(
imag
:scs
(
long-reg
)
:to
:save
))
(
:arg-types
long-float
long-float
)
(
:results
(
r
:scs
(
complex-long-reg
)
:from
(
:argument
0
)
:load-if
(
not
(
sc-is
r
complex-long-stack
))))
(
:result-types
complex-long-float
)
(
:note
_N
"inline complex long-float creation"
)
(
:policy
:fast-safe
)
(
:vop-var
vop
)
(
:generator
5
(
sc-case
r
(
complex-long-reg
(
let
((
r-real
(
complex-long-reg-real-tn
r
)))
(
unless
(
location=
real
r-real
)
(
move-long-reg
r-real
real
)))
(
let
((
r-imag
(
complex-long-reg-imag-tn
r
)))
(
unless
(
location=
imag
r-imag
)
(
move-long-reg
r-imag
imag
))))
(
complex-long-stack
(
let
((
nfp
(
current-nfp-tn
vop
))
(
offset
(
*
(
tn-offset
r
)
vm:word-bytes
)))
(
unless
(
location=
real
r
)
(
store-long-reg
real
nfp
offset
))
(
store-long-reg
imag
nfp
(
+
offset
(
*
4
vm:word-bytes
))))))))
(
not-implemented
)))
(
define-vop
(
complex-single-float-value
)
(
:args
(
x
:scs
(
complex-single-reg
descriptor-reg
)
:target
r
...
...
@@ -1475,23 +934,7 @@
(
:policy
:fast-safe
)
(
:vop-var
vop
)
(
:generator
3
(
sc-case
x
(
complex-single-reg
(
let
((
value-tn
(
ecase
slot
(
:real
(
complex-single-reg-real-tn
x
))
(
:imag
(
complex-single-reg-imag-tn
x
)))))
(
unless
(
location=
value-tn
r
)
(
inst
fmovs
r
value-tn
))))
(
complex-single-stack
(
inst
ldf
r
(
current-nfp-tn
vop
)
(
*
(
+
(
ecase
slot
(
:real
0
)
(
:imag
1
))
(
tn-offset
x
))
vm:word-bytes
)))
(
descriptor-reg
(
inst
ldf
r
x
(
-
(
*
(
ecase
slot
(
:real
vm::complex-single-float-real-slot
)
(
:imag
vm::complex-single-float-imag-slot
))
vm:word-bytes
)
vm:other-pointer-type
))))))
(
not-implemented
)))
(
define-vop
(
realpart/complex-single-float
complex-single-float-value
)
(
:translate
realpart
)
...
...
@@ -1513,23 +956,7 @@
(
:policy
:fast-safe
)
(
:vop-var
vop
)
(
:generator
3
(
sc-case
x
(
complex-double-reg
(
let
((
value-tn
(
ecase
slot
(
:real
(
complex-double-reg-real-tn
x
))
(
:imag
(
complex-double-reg-imag-tn
x
)))))
(
unless
(
location=
value-tn
r
)
(
move-double-reg
r
value-tn
))))
(
complex-double-stack
(
inst
lddf
r
(
current-nfp-tn
vop
)
(
*
(
+
(
ecase
slot
(
:real
0
)
(
:imag
2
))
(
tn-offset
x
))
vm:word-bytes
)))
(
descriptor-reg
(
inst
lddf
r
x
(
-
(
*
(
ecase
slot
(
:real
vm::complex-double-float-real-slot
)
(
:imag
vm::complex-double-float-imag-slot
))
vm:word-bytes
)
vm:other-pointer-type
))))))
(
not-implemented
)))
(
define-vop
(
realpart/complex-double-float
complex-double-float-value
)
(
:translate
realpart
)
...
...
@@ -1541,41 +968,6 @@
(
:note
_N
"complex double float imagpart"
)
(
:variant
:imag
))
#+
long-float
(
define-vop
(
complex-long-float-value
)
(
:args
(
x
:scs
(
complex-long-reg
)
:target
r
:load-if
(
not
(
sc-is
x
complex-long-stack
))))
(
:arg-types
complex-long-float
)
(
:results
(
r
:scs
(
long-reg
)))
(
:result-types
long-float
)
(
:variant-vars
slot
)
(
:policy
:fast-safe
)
(
:vop-var
vop
)
(
:generator
4
(
sc-case
x
(
complex-long-reg
(
let
((
value-tn
(
ecase
slot
(
:real
(
complex-long-reg-real-tn
x
))
(
:imag
(
complex-long-reg-imag-tn
x
)))))
(
unless
(
location=
value-tn
r
)
(
move-long-reg
r
value-tn
))))
(
complex-long-stack
(
load-long-reg
r
(
current-nfp-tn
vop
)
(
*
(
+
(
ecase
slot
(
:real
0
)
(
:imag
4
))
(
tn-offset
x
))
vm:word-bytes
))))))
#+
long-float
(
define-vop
(
realpart/complex-long-float
complex-long-float-value
)
(
:translate
realpart
)
(
:note
_N
"complex long float realpart"
)
(
:variant
:real
))
#+
long-float
(
define-vop
(
imagpart/complex-long-float
complex-long-float-value
)
(
:translate
imagpart
)
(
:note
_N
"complex long float imagpart"
)
(
:variant
:imag
))
;;;; Complex float arithmetic
...
...
@@ -1616,7 +1008,7 @@
(
ri
(
,
imag-tn
r
)))
(
,@
fneg
rr
xr
)
(
,@
fneg
ri
xi
)))))))
(
frob
single
(
inst
f
neg
s
)
4
)
(
frob
single
(
inst
v
neg
)
4
)
(
frob
double
(
negate-double-reg
)
4
))
;; Add and subtract for two complex arguments
...
...
@@ -1644,10 +1036,10 @@
(
ri
(
,
imag-part
r
)))
(
inst
,
inst
rr
xr
yr
)
(
inst
,
inst
ri
xi
yi
)))))))
(
frob
+
f
add
s
single
4
)
(
frob
+
fad
dd
double
4
)
(
frob
-
f
sub
s
single
4
)
(
frob
-
f
sub
d
double
4
))
(
frob
+
v
add
single
4
)
(
frob
+
va
dd
double
4
)
(
frob
-
v
sub
single
4
)
(
frob
-
v
sub
double
4
))
;; Add and subtract a complex and a float
...
...
@@ -1698,10 +1090,10 @@
(
inst
,
fop
rr
xr
y
)
(
inst
,
fop
ri
xi
zero
)))))))
(
frob
single
+
f
add
s
2
)
(
frob
single
-
f
sub
s
2
)
(
frob
double
+
fad
dd
4
)
(
frob
double
-
f
sub
d
4
))
(
frob
single
+
v
add
2
)
(
frob
single
-
v
sub
2
)
(
frob
double
+
va
dd
4
)
(
frob
double
-
v
sub
4
))
;; Add a float and a complex
(
macrolet
...
...
@@ -1744,8 +1136,8 @@
vm:other-pointer-type
))
(
inst
,
fop
rr
xr
y
)
(
inst
,
fop
ri
xi
zero
)))))))
(
frob
single
f
add
s
1
)
(
frob
double
fad
dd
2
))
(
frob
single
v
add
1
)
(
frob
double
va
dd
2
))
;; Subtract a complex from a float.
;;
...
...
@@ -1839,8 +1231,8 @@
(
inst
,
fmul
ri
xi
yr
)
(
inst
,
fadd
ri
ri
p1
)))))))))
(
frob
single
fmuls
f
add
s
fsubs
6
)
(
frob
double
fmuld
fad
dd
fsubd
6
))
(
frob
single
fmuls
v
add
fsubs
6
)
(
frob
double
fmuld
va
dd
fsubd
6
))
;; Multiply a complex by a float. The case of float * complex is
;; handled by a deftransform to convert it to the complex*float case.
...
...
@@ -2114,7 +1506,7 @@
(
,@
fneg
ri
ri
)))))))
(
frob
single
fcmps
fadds
fmuls
fdivs
(
inst
f
neg
s
)
(
inst
f
abs
s
)
10
)
(
frob
single
fcmps
fadds
fmuls
fdivs
(
inst
v
neg
)
(
inst
v
abs
)
10
)
(
frob
double
fcmpd
faddd
fmuld
fdivd
(
negate-double-reg
)
(
abs-double-reg
)
10
))
;; Conjugate of a complex number
...
...
@@ -2143,7 +1535,7 @@
(
unless
(
location=
rr
xr
)
(
,@
fmov
rr
xr
))))))))
(
frob
single
(
inst
f
neg
s
)
(
inst
f
mov
s
)
4
)
(
frob
single
(
inst
v
neg
)
(
inst
v
mov
)
4
)
(
frob
double
(
negate-double-reg
)
(
move-double-reg
)
4
))
;; Compare a float with a complex or a complex with a float
...
...
@@ -2265,57 +1657,7 @@
(
:guard
(
not
(
backend-featurep
:sparc-v9
)))
(
:generator
6
(
note-this-location
vop
:internal-error
)
(
let
((
xr
(
,
real-part
x
))
(
xi
(
,
imag-part
x
))
(
yr
(
,
real-part
y
))
(
yi
(
,
imag-part
y
)))
(
inst
,
fcmp
xr
yr
)
(
inst
nop
)
(
inst
fb
(
if
not-p
:ne
:eq
)
target
#+
sparc-v9
:fcc0
#+
sparc-v9
:pn
)
(
inst
,
fcmp
xi
yi
)
(
inst
nop
)
(
inst
fb
(
if
not-p
:ne
:eq
)
target
#+
sparc-v9
:fcc0
#+
sparc-v9
:pn
)
(
inst
nop
)))))))
(
frob
single
fcmps
)
(
frob
double
fcmpd
))
;; Compare a complex with a complex, for V9
(
macrolet
((
frob
(
float-type
fcmp
)
(
let
((
vop-name
(
symbolicate
"V9-COMPLEX-"
float-type
"-FLOAT-COMPARE"
))
(
complex-reg
(
symbolicate
"COMPLEX-"
float-type
"-REG"
))
(
c-type
(
symbolicate
"COMPLEX-"
float-type
"-FLOAT"
))
(
real-part
(
symbolicate
"COMPLEX-"
float-type
"-REG-REAL-TN"
))
(
imag-part
(
symbolicate
"COMPLEX-"
float-type
"-REG-IMAG-TN"
)))
`
(
define-vop
(
,
vop-name
)
(
:args
(
x
:scs
(
,
complex-reg
))
(
y
:scs
(
,
complex-reg
)))
(
:arg-types
,
c-type
,
c-type
)
(
:translate
=
)
(
:conditional
)
(
:info
target
not-p
)
(
:policy
:fast-safe
)
(
:note
_N
"inline complex float comparison"
)
(
:vop-var
vop
)
(
:save-p
:compute-only
)
(
:temporary
(
:sc
descriptor-reg
)
true
)
(
:guard
(
backend-featurep
:sparc-v9
))
(
:generator
6
(
note-this-location
vop
:internal-error
)
(
let
((
xr
(
,
real-part
x
))
(
xi
(
,
imag-part
x
))
(
yr
(
,
real-part
y
))
(
yi
(
,
imag-part
y
)))
;; Assume comparison is true
(
load-symbol
true
t
)
(
inst
,
fcmp
xr
yr
)
(
inst
cmove
(
if
not-p
:eq
:ne
)
true
null-tn
:fcc0
)
(
inst
,
fcmp
xi
yi
)
(
inst
cmove
(
if
not-p
:eq
:ne
)
true
null-tn
:fcc0
)
(
inst
cmp
true
null-tn
)
(
inst
b
(
if
not-p
:eq
:ne
)
target
:pt
)
(
inst
nop
)))))))
(
not-implemented
))))))
(
frob
single
fcmps
)
(
frob
double
fcmpd
))
...
...
@@ -2337,240 +1679,6 @@
)
; end progn complex-fp-vops
#+
sparc-v9
(
progn
;; Vops to take advantage of the conditional move instruction
;; available on the Sparc V9
(
defknown
(
%%max
%%min
)
((
or
(
unsigned-byte
#.
vm:word-bits
)
(
signed-byte
#.
vm:word-bits
)
single-float
double-float
)
(
or
(
unsigned-byte
#.
vm:word-bits
)
(
signed-byte
#.
vm:word-bits
)
single-float
double-float
))
(
or
(
unsigned-byte
#.
vm:word-bits
)
(
signed-byte
#.
vm:word-bits
)
single-float
double-float
)
(
movable
foldable
flushable
))
;; We need these definitions for byte-compiled code
(
defun
%%min
(
x
y
)
(
declare
(
type
(
or
(
unsigned-byte
32
)
(
signed-byte
32
)
single-float
double-float
)
x
y
))
(
if
(
<=
x
y
)
x
y
))
(
defun
%%max
(
x
y
)
(
declare
(
type
(
or
(
unsigned-byte
32
)
(
signed-byte
32
)
single-float
double-float
)
x
y
))
(
if
(
>=
x
y
)
x
y
))
(
macrolet
((
frob
(
name
sc-type
type
compare
cmov
cost
cc
max
min
note
)
(
let
((
vop-name
(
symbolicate
name
"-"
type
"=>"
type
))
(
trans-name
(
symbolicate
"%%"
name
)))
`
(
define-vop
(
,
vop-name
)
(
:args
(
x
:scs
(
,
sc-type
))
(
y
:scs
(
,
sc-type
)))
(
:results
(
r
:scs
(
,
sc-type
)))
(
:arg-types
,
type
,
type
)
(
:result-types
,
type
)
(
:policy
:fast-safe
)
(
:note
,
note
)
(
:translate
,
trans-name
)
(
:guard
(
backend-featurep
:sparc-v9
))
(
:generator
,
cost
(
inst
,
compare
x
y
)
(
cond
((
location=
r
x
)
;; If x < y, need to move y to r, otherwise r already has
;; the max.
(
inst
,
cmov
,
min
r
y
,
cc
))
((
location=
r
y
)
;; If x > y, need to move x to r, otherwise r already has
;; the max.
(
inst
,
cmov
,
max
r
x
,
cc
))
(
t
;; It doesn't matter what R is, just copy the min to R.
(
inst
,
cmov
,
max
r
x
,
cc
)
(
inst
,
cmov
,
min
r
y
,
cc
))))))))
(
frob
max
single-reg
single-float
fcmps
cfmovs
3
:fcc0
:ge
:l
_N
"inline float max"
)
(
frob
max
double-reg
double-float
fcmpd
cfmovd
3
:fcc0
:ge
:l
_N
"inline float max"
)
(
frob
min
single-reg
single-float
fcmps
cfmovs
3
:fcc0
:l
:ge
_N
"inline float min"
)
(
frob
min
double-reg
double-float
fcmpd
cfmovd
3
:fcc0
:l
:ge
_N
"inline float min"
)
;; Strictly speaking these aren't float ops, but it's convenient to
;; do them here.
;;
;; The cost is here is the worst case number of instructions. For
;; 32-bit integer operands, we add 2 more to account for the
;; untagging of fixnums, if necessary.
(
frob
max
signed-reg
signed-num
cmp
cmove
5
:icc
:ge
:lt
_N
"inline (signed-byte 32) max"
)
(
frob
max
unsigned-reg
unsigned-num
cmp
cmove
5
:icc
:ge
:lt
_N
"inline (unsigned-byte 32) max"
)
;; For fixnums, make the cost lower so we don't have to untag the
;; numbers.
(
frob
max
any-reg
tagged-num
cmp
cmove
3
:icc
:ge
:lt
_N
"inline fixnum max"
)
(
frob
min
signed-reg
signed-num
cmp
cmove
5
:icc
:lt
:ge
_N
"inline (signed-byte 32) min"
)
(
frob
min
unsigned-reg
unsigned-num
cmp
cmove
5
:icc
:lt
:ge
_N
"inline (unsigned-byte 32) min"
)
;; For fixnums, make the cost lower so we don't have to untag the
;; numbers.
(
frob
min
any-reg
tagged-num
cmp
cmove
3
:icc
:lt
:ge
_N
"inline fixnum min"
))
#+
nil
(
define-vop
(
max-boxed-double-float=>boxed-double-float
)
(
:args
(
x
:scs
(
descriptor-reg
))
(
y
:scs
(
descriptor-reg
)))
(
:results
(
r
:scs
(
descriptor-reg
)))
(
:arg-types
double-float
double-float
)
(
:result-types
double-float
)
(
:policy
:fast-safe
)
(
:note
_N
"inline float max/min"
)
(
:translate
%max-double-float
)
(
:temporary
(
:scs
(
double-reg
))
xval
)
(
:temporary
(
:scs
(
double-reg
))
yval
)
(
:guard
(
backend-featurep
:sparc-v9
))
(
:vop-var
vop
)
(
:generator
3
(
let
((
offset
(
-
(
*
vm:double-float-value-slot
vm:word-bytes
)
vm:other-pointer-type
)))
(
inst
lddf
xval
x
offset
)
(
inst
lddf
yval
y
offset
)
(
inst
fcmpd
xval
yval
)
(
cond
((
location=
r
x
)
;; If x < y, need to move y to r, otherwise r already has
;; the max.
(
inst
cmove
:l
r
y
:fcc0
))
((
location=
r
y
)
;; If x > y, need to move x to r, otherwise r already has
;; the max.
(
inst
cmove
:ge
r
x
:fcc0
))
(
t
;; It doesn't matter what R is, just copy the min to R.
(
inst
cmove
:ge
r
x
:fcc0
)
(
inst
cmove
:l
r
y
:fcc0
))))))
)
(
in-package
"C"
)
#+
sparc-v9
(
progn
;;; The sparc-v9 architecture has conditional move instructions that
;;; can be used. This should be faster than using the obvious if
;;; expression since we don't have to do branches.
(
def-source-transform
min
(
&rest
args
)
(
case
(
length
args
)
((
0
2
)
(
values
nil
t
))
(
1
`
(
values
(
the
real
,
(
first
args
))))
(
t
(
c::associate-arguments
'min
(
first
args
)
(
rest
args
)))))
(
def-source-transform
max
(
&rest
args
)
(
case
(
length
args
)
((
0
2
)
(
values
nil
t
))
(
1
`
(
values
(
the
real
,
(
first
args
))))
(
t
(
c::associate-arguments
'max
(
first
args
)
(
rest
args
)))))
;; Derive the types of max and min
(
defoptimizer
(
max
derive-type
)
((
x
y
))
;; It's Y < X instead of X < Y because that's how the
;; source-transform, the deftransform and the max function do the
;; comparisons. This is important if the types of X and Y are
;; different types, like integer vs double-float because CMUCL
;; returns the actual arg, instead of applying float-contagion to
;; the result.
(
multiple-value-bind
(
definitely-<
definitely->=
)
(
ir1-transform-<-helper
y
x
)
(
cond
(
definitely-<
(
continuation-type
x
))
(
definitely->=
(
continuation-type
y
))
(
t
(
make-canonical-union-type
(
list
(
continuation-type
x
)
(
continuation-type
y
)))))))
(
defoptimizer
(
min
derive-type
)
((
x
y
))
(
multiple-value-bind
(
definitely->
definitely-<=
)
(
ir1-transform-<-helper
y
x
)
(
cond
(
definitely-<=
(
continuation-type
x
))
(
definitely->
(
continuation-type
y
))
(
t
(
make-canonical-union-type
(
list
(
continuation-type
x
)
(
continuation-type
y
)))))))
(
deftransform
max
((
x
y
)
(
number
number
)
*
:when
:both
)
(
let
((
x-type
(
continuation-type
x
))
(
y-type
(
continuation-type
y
))
(
signed
(
specifier-type
'
(
signed-byte
#.
vm:word-bits
)))
(
unsigned
(
specifier-type
'
(
unsigned-byte
#.
vm:word-bits
)))
(
d-float
(
specifier-type
'double-float
))
(
s-float
(
specifier-type
'single-float
)))
;; Use %%max if both args are good types of the same type. As a
;; last resort, use the obvious comparison to select the desired
;; element.
(
cond
((
and
(
csubtypep
x-type
signed
)
(
csubtypep
y-type
signed
))
`
(
sparc::%%max
x
y
))
((
and
(
csubtypep
x-type
unsigned
)
(
csubtypep
y-type
unsigned
))
`
(
sparc::%%max
x
y
))
((
and
(
csubtypep
x-type
d-float
)
(
csubtypep
y-type
d-float
))
`
(
sparc::%%max
x
y
))
((
and
(
csubtypep
x-type
s-float
)
(
csubtypep
y-type
s-float
))
`
(
sparc::%%max
x
y
))
(
t
(
let
((
arg1
(
gensym
))
(
arg2
(
gensym
)))
`
(
let
((
,
arg1
x
)
(
,
arg2
y
))
(
if
(
>
,
arg1
,
arg2
)
,
arg1
,
arg2
)))))))
(
deftransform
min
((
x
y
)
(
real
real
)
*
:when
:both
)
(
let
((
x-type
(
continuation-type
x
))
(
y-type
(
continuation-type
y
))
(
signed
(
specifier-type
'
(
signed-byte
#.
vm:word-bits
)))
(
unsigned
(
specifier-type
'
(
unsigned-byte
#.
vm:word-bits
)))
(
d-float
(
specifier-type
'double-float
))
(
s-float
(
specifier-type
'single-float
)))
(
cond
((
and
(
csubtypep
x-type
signed
)
(
csubtypep
y-type
signed
))
`
(
sparc::%%min
x
y
))
((
and
(
csubtypep
x-type
unsigned
)
(
csubtypep
y-type
unsigned
))
`
(
sparc::%%min
x
y
))
((
and
(
csubtypep
x-type
d-float
)
(
csubtypep
y-type
d-float
))
`
(
sparc::%%min
x
y
))
((
and
(
csubtypep
x-type
s-float
)
(
csubtypep
y-type
s-float
))
`
(
sparc::%%min
x
y
))
(
t
(
let
((
arg1
(
gensym
))
(
arg2
(
gensym
)))
`
(
let
((
,
arg1
x
)
(
,
arg2
y
))
(
if
(
<
,
arg1
,
arg2
)
,
arg1
,
arg2
)))))))
)
(
in-package
"SPARC"
)
;;; Support for double-double floats
...
...
@@ -2592,18 +1700,18 @@
(
let
((
nfp
(
current-nfp-tn
vop
))
(
offset
(
*
(
tn-offset
x
)
vm:word-bytes
)))
(
let
((
hi-tn
(
double-double-reg-hi-tn
y
)))
(
inst
ld
df
hi-tn
nfp
offset
))
(
inst
v
ld
r
hi-tn
(
make-ea
nfp
:
offset
offset
)
))
(
let
((
lo-tn
(
double-double-reg-lo-tn
y
)))
(
inst
ld
df
lo-tn
nfp
(
+
offset
(
*
2
vm:word-bytes
))))))
(
inst
v
ld
r
lo-tn
(
make-ea
nfp
:offset
(
+
offset
(
*
2
vm:word-bytes
))))))
)
(
define-move-function
(
store-double-double
4
)
(
vop
x
y
)
((
double-double-reg
)
(
double-double-stack
))
(
let
((
nfp
(
current-nfp-tn
vop
))
(
offset
(
*
(
tn-offset
y
)
vm:word-bytes
)))
(
let
((
hi-tn
(
double-double-reg-hi-tn
x
)))
(
inst
st
df
hi-tn
nfp
offset
))
(
inst
v
st
r
hi-tn
(
make-ea
nfp
:
offset
offset
)
))
(
let
((
lo-tn
(
double-double-reg-lo-tn
x
)))
(
inst
st
df
lo-tn
nfp
(
+
offset
(
*
2
vm:word-bytes
))))))
(
inst
v
st
r
lo-tn
(
make-ea
nfp
:offset
(
+
offset
(
*
2
vm:word-bytes
))))))
)
;;; Double-double float register to register moves
...
...
@@ -2638,13 +1746,15 @@
(
with-fixed-allocation
(
y
ndescr
vm::double-double-float-type
vm::double-double-float-size
))
(
let
((
hi-tn
(
double-double-reg-hi-tn
x
)))
(
inst
stdf
hi-tn
y
(
-
(
*
vm::double-double-float-hi-slot
(
inst
vstr
hi-tn
(
make-ea
y
:offset
(
-
(
*
vm::double-double-float-hi-slot
vm:word-bytes
)
vm:other-pointer-type
)))
vm:other-pointer-type
)))
)
(
let
((
lo-tn
(
double-double-reg-lo-tn
x
)))
(
inst
stdf
lo-tn
y
(
-
(
*
vm::double-double-float-lo-slot
(
inst
vstr
lo-tn
(
make-ea
y
:offset
(
-
(
*
vm::double-double-float-lo-slot
vm:word-bytes
)
vm:other-pointer-type
)))))
vm:other-pointer-type
)))))
)
;;;
(
define-move-vop
move-from-double-double
:move
(
double-double-reg
)
(
descriptor-reg
))
...
...
@@ -2657,11 +1767,13 @@
(
:note
_N
"pointer to double-double float coercion"
)
(
:generator
2
(
let
((
hi-tn
(
double-double-reg-hi-tn
y
)))
(
inst
lddf
hi-tn
x
(
-
(
*
double-double-float-hi-slot
word-bytes
)
other-pointer-type
)))
(
inst
vldr
hi-tn
(
make-ea
x
:offset
(
-
(
*
double-double-float-hi-slot
word-bytes
)
other-pointer-type
))))
(
let
((
lo-tn
(
double-double-reg-lo-tn
y
)))
(
inst
lddf
lo-tn
x
(
-
(
*
double-double-float-lo-slot
word-bytes
)
other-pointer-type
)))))
(
inst
vldr
lo-tn
(
make-ea
x
:offset
(
-
(
*
double-double-float-lo-slot
word-bytes
)
other-pointer-type
))))))
(
define-move-vop
move-to-double-double
:move
(
descriptor-reg
)
(
double-double-reg
))
...
...
@@ -2686,9 +1798,9 @@
(
double-double-stack
(
let
((
offset
(
*
(
tn-offset
y
)
word-bytes
)))
(
let
((
hi-tn
(
double-double-reg-hi-tn
x
)))
(
inst
st
df
hi-tn
nfp
offset
))
(
inst
v
st
r
hi-tn
(
make-ea
nfp
:
offset
offset
)
))
(
let
((
lo-tn
(
double-double-reg-lo-tn
x
)))
(
inst
st
df
lo-tn
nfp
(
+
offset
(
*
2
word-bytes
)))))))))
(
inst
v
st
r
lo-tn
(
make-ea
nfp
:offset
(
+
offset
(
*
2
word-bytes
)))))))))
)
(
define-move-vop
move-double-double-float-argument
:move-argument
(
double-double-reg
descriptor-reg
)
(
double-double-reg
))
...
...
@@ -2719,8 +1831,8 @@
(
let
((
nfp
(
current-nfp-tn
vop
))
(
offset
(
*
(
tn-offset
res
)
vm:word-bytes
)))
(
unless
(
location=
hi
res
)
(
inst
st
df
hi
nfp
offset
))
(
inst
st
df
lo
nfp
(
+
offset
(
*
2
vm:word-bytes
))))))))
(
inst
v
st
r
hi
(
make-ea
nfp
:
offset
offset
)
))
(
inst
v
st
r
lo
(
make-ea
nfp
:offset
(
+
offset
(
*
2
vm:word-bytes
))))))))
)
(
define-vop
(
double-double-float-value
)
(
:args
(
x
:scs
(
double-double-reg
descriptor-reg
)
:target
r
...
...
@@ -2740,15 +1852,17 @@
(
unless
(
location=
value-tn
r
)
(
move-double-reg
r
value-tn
))))
(
double-double-stack
(
inst
lddf
r
(
current-nfp-tn
vop
)
(
*
(
+
(
ecase
slot
(
:hi
0
)
(
:lo
2
))
(
inst
vldr
r
(
make-ea
(
current-nfp-tn
vop
)
:offset
(
*
(
+
(
ecase
slot
(
:hi
0
)
(
:lo
2
))
(
tn-offset
x
))
vm:word-bytes
)))
vm:word-bytes
)))
)
(
descriptor-reg
(
inst
lddf
r
x
(
-
(
*
vm:word-bytes
(
inst
vldr
r
(
make-ea
x
:offste
(
-
(
*
vm:word-bytes
(
ecase
slot
(
:hi
vm:double-double-float-hi-slot
)
(
:lo
vm:double-double-float-lo-slot
)))
vm:other-pointer-type
))))))
vm:other-pointer-type
))))))
)
(
define-vop
(
hi/double-double-value
double-double-float-value
)
(
:translate
kernel::double-double-hi
)
...
...
@@ -2792,13 +1906,13 @@
(
let
((
nfp
(
current-nfp-tn
vop
))
(
offset
(
*
(
tn-offset
r
)
vm:word-bytes
)))
(
let
((
r-real
(
double-double-reg-hi-tn
real
)))
(
inst
st
df
r-real
nfp
offset
))
(
inst
v
st
r
r-real
(
make-ea
nfp
:
offset
offset
)
))
(
let
((
r-real
(
double-double-reg-lo-tn
real
)))
(
inst
st
df
r-real
nfp
(
+
offset
(
*
2
vm:word-bytes
))))
(
inst
v
st
r
r-real
(
make-ea
nfp
:offset
(
+
offset
(
*
2
vm:word-bytes
))))
)
(
let
((
r-imag
(
double-double-reg-hi-tn
imag
)))
(
inst
st
df
r-imag
nfp
(
+
offset
(
*
4
vm:word-bytes
))))
(
inst
v
st
r
r-imag
(
make-ea
nfp
:offset
(
+
offset
(
*
4
vm:word-bytes
))))
)
(
let
((
r-imag
(
double-double-reg-lo-tn
imag
)))
(
inst
st
df
r-imag
nfp
(
+
offset
(
*
6
vm:word-bytes
)))))))))
(
inst
v
st
r
r-imag
(
make-ea
nfp
:offset
(
+
offset
(
*
6
vm:word-bytes
)))))))))
)
(
define-vop
(
complex-double-double-float-value
)
(
:args
(
x
:scs
(
complex-double-double-reg
descriptor-reg
)
...
...
@@ -2826,26 +1940,34 @@
(
move-double-reg
r-lo
value-tn
))))
(
complex-double-double-stack
(
let
((
r-hi
(
double-double-reg-hi-tn
r
)))
(
inst
lddf
r-hi
(
current-nfp-tn
vop
)
(
*
(
+
(
ecase
slot
(
:real
0
)
(
:imag
4
))
(
inst
vldr
r-hi
(
make-ea
(
current-nfp-tn
vop
)
:offset
(
*
(
+
(
ecase
slot
(
:real
0
)
(
:imag
4
))
(
tn-offset
x
))
vm:word-bytes
)))
vm:word-bytes
)))
)
(
let
((
r-lo
(
double-double-reg-lo-tn
r
)))
(
inst
lddf
r-lo
(
current-nfp-tn
vop
)
(
*
(
+
(
ecase
slot
(
:real
2
)
(
:imag
6
))
(
inst
vldr
r-lo
(
make-ea
(
current-nfp-tn
vop
)
:offset
(
*
(
+
(
ecase
slot
(
:real
2
)
(
:imag
6
))
(
tn-offset
x
))
vm:word-bytes
))))
vm:word-bytes
))))
)
(
descriptor-reg
(
let
((
r-hi
(
double-double-reg-hi-tn
r
)))
(
inst
lddf
r-hi
x
(
-
(
*
(
ecase
slot
(
inst
vldr
r-hi
(
make-ea
x
:offset
(
-
(
*
(
ecase
slot
(
:real
vm::complex-double-double-float-real-hi-slot
)
(
:imag
vm::complex-double-double-float-imag-hi-slot
))
vm:word-bytes
)
vm:other-pointer-type
))
vm:other-pointer-type
))
))
(
let
((
r-lo
(
double-double-reg-lo-tn
r
)))
(
inst
lddf
r-lo
x
(
-
(
*
(
ecase
slot
(
inst
vldr
r-lo
(
make-ea
x
:offset
(
-
(
*
(
ecase
slot
(
:real
vm::complex-double-double-float-real-lo-slot
)
(
:imag
vm::complex-double-double-float-imag-lo-slot
))
vm:word-bytes
)
vm:other-pointer-type
))))))))
vm:other-pointer-type
))))))))
)
(
define-vop
(
realpart/complex-double-double-float
complex-double-double-float-value
)
(
:translate
realpart
)
...
...
...
...
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
sign in
to comment