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
af966489
Commit
af966489
authored
16 years ago
by
rtoy
Browse files
Options
Downloads
Patches
Plain Diff
Actually implement the DATA-VECTOR-REF-C and DATA-VECTOR-SET-C vops
for the double-double float arrays that we support.
parent
04ab4585
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/x86/array.lisp
+157
-112
157 additions, 112 deletions
compiler/x86/array.lisp
with
157 additions
and
112 deletions
compiler/x86/array.lisp
+
157
−
112
View file @
af966489
...
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/array.lisp,v 1.
19
200
6
/0
6/30 18:41:32
rtoy Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/array.lisp,v 1.
20
200
8
/0
4/15 03:24:21
rtoy Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -1590,7 +1590,6 @@
(
:arg-types
simple-array-double-double-float
positive-fixnum
)
(
:results
(
value
:scs
(
double-double-reg
)))
(
:result-types
double-double-float
)
;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
(
:generator
7
(
let
((
hi-tn
(
double-double-reg-hi-tn
value
)))
(
with-empty-tn@fp-top
(
hi-tn
)
...
...
@@ -1604,7 +1603,6 @@
8
)
vm:other-pointer-type
)))))))
#+
nil
(
define-vop
(
data-vector-ref-c/simple-array-double-double-float
)
(
:note
"inline array access"
)
(
:translate
data-vector-ref
)
...
...
@@ -1614,21 +1612,20 @@
(
:info
index
)
(
:results
(
value
:scs
(
double-double-reg
)))
(
:result-types
double-double-float
)
;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
(
:generator
5
(
let
((
offset
(
+
(
*
index
16
)
(
-
(
*
vm:vector-data-offset
vm:word-bytes
)
vm:other-pointer-type
)))
(
hi-tn
(
double-double-reg-hi-tn
value
)
)
(
lo-tn
(
double-double-reg-lo-tn
value
)
))
(
cond
((
typep
(
+
offset
8
)
'
(
signed-byte
13
))
(
inst
lddf
hi-tn
object
offset
)
(
inst
lddf
lo-tn
object
(
+
offset
8
))
)
(
t
(
inst
li
temp
offset
)
(
inst
lddf
hi-tn
object
temp
)
(
inst
add
temp
(
*
2
vm:word-bytes
)
)
(
inst
lddf
lo-tn
object
temp
))))))
(
let
((
hi-tn
(
double-double-reg-hi-tn
value
))
)
(
with-empty-tn@fp-top
(
hi-tn
)
(
inst
fldd
(
make-ea
:dword
:base
object
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:word-bytes
)
(
*
16
index
))
vm:other-pointer-type
)))
))
(
let
((
lo-tn
(
double-double-reg-lo-tn
value
))
)
(
with-empty-tn@fp-top
(
lo-tn
)
(
inst
fldd
(
make-ea
:dword
:base
objec
t
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:word-bytes
)
(
*
16
index
)
8
)
vm:other-pointer-type
)
))))))
(
define-vop
(
data-vector-set/simple-array-double-double-float
)
(
:note
"inline array store"
)
...
...
@@ -1641,7 +1638,6 @@
double-double-float
)
(
:results
(
result
:scs
(
double-double-reg
)))
(
:result-types
double-double-float
)
;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
(
:generator
20
(
let
((
value-real
(
double-double-reg-hi-tn
value
))
(
result-real
(
double-double-reg-hi-tn
result
)))
...
...
@@ -1680,7 +1676,6 @@
(
inst
fstd
result-imag
))
(
inst
fxch
value-imag
))))
#+
nil
(
define-vop
(
data-vector-set-c/simple-array-double-double-float
)
(
:note
"inline array store"
)
(
:translate
data-vector-set
)
...
...
@@ -1693,31 +1688,46 @@
(
:info
index
)
(
:results
(
result
:scs
(
double-double-reg
)))
(
:result-types
double-double-float
)
;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
(
:generator
15
(
let
((
value-hi
(
double-double-reg-hi-tn
value
))
(
result-hi
(
double-double-reg-hi-tn
result
))
(
value-lo
(
double-double-reg-lo-tn
value
))
(
result-lo
(
double-double-reg-lo-tn
result
))
(
offset
(
+
(
*
index
16
)
(
-
(
*
vm:vector-data-offset
vm:word-bytes
)
vm:other-pointer-type
))))
;; There's a possible optimization here if the offset for the
;; real part fits in a signed-byte 13 but the imag part doesn't.
;; We don't do this because it can't happen with the current
;; values of vm:other-pointer-type and vm:vector-data-offset.
(
cond
((
typep
(
+
offset
8
)
'
(
signed-byte
13
))
(
inst
stdf
value-hi
object
offset
)
(
inst
stdf
value-lo
object
(
+
offset
8
)))
(
:generator
20
(
let
((
value-real
(
double-double-reg-hi-tn
value
))
(
result-real
(
double-double-reg-hi-tn
result
)))
(
cond
((
zerop
(
tn-offset
value-real
))
;; Value is in ST0
(
inst
fstd
(
make-ea
:dword
:base
object
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:word-bytes
)
(
*
16
index
))
vm:other-pointer-type
)))
(
unless
(
zerop
(
tn-offset
result-real
))
;; Value is in ST0 but not result.
(
inst
fstd
result-real
)))
(
t
(
inst
li
temp
offset
)
(
inst
stdf
value-hi
object
temp
)
(
inst
add
temp
8
)
(
inst
stdf
value-lo
object
temp
)))
(
unless
(
location=
result-hi
value-hi
)
(
move-double-reg
result-hi
value-hi
))
(
unless
(
location=
result-lo
value-lo
)
(
move-double-reg
result-lo
value-lo
)))))
;; Value is not in ST0.
(
inst
fxch
value-real
)
(
inst
fstd
(
make-ea
:dword
:base
object
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:word-bytes
)
(
*
16
index
))
vm:other-pointer-type
)))
(
cond
((
zerop
(
tn-offset
result-real
))
;; The result is in ST0.
(
inst
fstd
value-real
))
(
t
;; Neither value or result are in ST0
(
unless
(
location=
value-real
result-real
)
(
inst
fstd
result-real
))
(
inst
fxch
value-real
))))))
(
let
((
value-imag
(
double-double-reg-lo-tn
value
))
(
result-imag
(
double-double-reg-lo-tn
result
)))
(
inst
fxch
value-imag
)
(
inst
fstd
(
make-ea
:dword
:base
object
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:word-bytes
)
(
*
16
index
)
8
)
vm:other-pointer-type
)))
(
unless
(
location=
value-imag
result-imag
)
(
inst
fstd
result-imag
))
(
inst
fxch
value-imag
))))
(
define-vop
(
data-vector-ref/simple-array-complex-double-double-float
)
(
:note
"inline array access"
)
...
...
@@ -1728,7 +1738,6 @@
(
:arg-types
simple-array-complex-double-double-float
positive-fixnum
)
(
:results
(
value
:scs
(
complex-double-double-reg
)))
(
:result-types
complex-double-double-float
)
;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
(
:generator
7
(
let
((
real-tn
(
complex-double-double-reg-real-hi-tn
value
)))
(
with-empty-tn@fp-top
(
real-tn
)
...
...
@@ -1754,7 +1763,6 @@
24
)
vm:other-pointer-type
)))))))
#+
nil
(
define-vop
(
data-vector-ref-c/simple-array-complex-double-double-float
)
(
:note
"inline array access"
)
(
:translate
data-vector-ref
)
...
...
@@ -1764,28 +1772,34 @@
(
:info
index
)
(
:results
(
value
:scs
(
complex-double-double-reg
)))
(
:result-types
complex-double-double-float
)
;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
(
:generator
5
(
let
((
offset
(
+
(
*
index
16
)
(
-
(
*
vm:vector-data-offset
vm:word-bytes
)
vm:other-pointer-type
)))
(
real-hi-tn
(
complex-double-double-reg-real-hi-tn
value
))
(
imag-hi-tn
(
complex-double-double-reg-imag-hi-tn
value
))
(
real-lo-tn
(
complex-double-double-reg-real-lo-tn
value
))
(
imag-lo-tn
(
complex-double-double-reg-imag-lo-tn
value
)))
(
cond
((
typep
(
+
offset
8
)
'
(
signed-byte
13
))
(
inst
lddf
real-hi-tn
object
offset
)
(
inst
lddf
imag-hi-tn
object
(
+
offset
(
*
2
vm:word-bytes
)))
(
inst
lddf
real-lo-tn
object
(
+
offset
(
*
4
vm:word-bytes
)))
(
inst
lddf
real-lo-tn
object
(
+
offset
(
*
6
vm:word-bytes
))))
(
t
(
inst
li
temp
offset
)
(
inst
lddf
real-hi-tn
object
temp
)
(
inst
add
temp
(
*
2
vm:word-bytes
))
(
inst
lddf
imag-hi-tn
object
temp
)
(
inst
lddf
real-lo-tn
object
temp
)
(
inst
add
temp
(
*
2
vm:word-bytes
))
(
inst
lddf
imag-lo-tn
object
temp
))))))
(
let
((
real-tn
(
complex-double-double-reg-real-hi-tn
value
)))
(
with-empty-tn@fp-top
(
real-tn
)
(
inst
fldd
(
make-ea
:dword
:base
object
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:word-bytes
)
(
*
32
index
))
vm:other-pointer-type
)))))
(
let
((
real-tn
(
complex-double-double-reg-real-lo-tn
value
)))
(
with-empty-tn@fp-top
(
real-tn
)
(
inst
fldd
(
make-ea
:dword
:base
object
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:word-bytes
)
(
*
32
index
)
8
)
vm:other-pointer-type
)))))
(
let
((
imag-tn
(
complex-double-double-reg-imag-hi-tn
value
)))
(
with-empty-tn@fp-top
(
imag-tn
)
(
inst
fldd
(
make-ea
:dword
:base
object
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:word-bytes
)
(
*
32
index
)
16
)
vm:other-pointer-type
)))))
(
let
((
imag-tn
(
complex-double-double-reg-imag-lo-tn
value
)))
(
with-empty-tn@fp-top
(
imag-tn
)
(
inst
fldd
(
make-ea
:dword
:base
object
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:word-bytes
)
(
*
32
index
)
24
)
vm:other-pointer-type
)))))))
(
define-vop
(
data-vector-set/simple-array-complex-double-double-float
)
(
:note
"inline array store"
)
...
...
@@ -1798,7 +1812,6 @@
complex-double-double-float
)
(
:results
(
result
:scs
(
complex-double-double-reg
)))
(
:result-types
complex-double-double-float
)
;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
(
:generator
20
(
let
((
value-real
(
complex-double-double-reg-real-hi-tn
value
))
(
result-real
(
complex-double-double-reg-real-hi-tn
result
)))
...
...
@@ -1875,7 +1888,6 @@
(
inst
fstd
result-imag
))
(
inst
fxch
value-imag
))))
#+
nil
(
define-vop
(
data-vector-set-c/simple-array-complex-double-double-float
)
(
:note
"inline array store"
)
(
:translate
data-vector-set
)
...
...
@@ -1888,53 +1900,86 @@
(
:info
index
)
(
:results
(
result
:scs
(
complex-double-double-reg
)))
(
:result-types
complex-double-double-float
)
;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
(
:generator
15
(
:generator
20
(
let
((
value-real
(
complex-double-double-reg-real-hi-tn
value
))
(
result-real
(
complex-double-double-reg-real-hi-tn
result
))
(
value-imag
(
complex-double-double-reg-imag-hi-tn
value
))
(
result-imag
(
complex-double-double-reg-imag-hi-tn
result
))
(
offset
(
+
(
*
index
16
)
(
-
(
*
vm:vector-data-offset
vm:word-bytes
)
vm:other-pointer-type
))))
;; There's a possible optimization here if the offset for the
;; real part fits in a signed-byte 13 but the imag part doesn't.
;; We don't do this because it can't happen with the current
;; values of vm:other-pointer-type and vm:vector-data-offset.
(
cond
((
typep
(
+
offset
8
)
'
(
signed-byte
13
))
(
inst
stdf
value-real
object
offset
)
(
inst
stdf
value-imag
object
(
+
offset
8
)))
(
result-real
(
complex-double-double-reg-real-hi-tn
result
)))
(
cond
((
zerop
(
tn-offset
value-real
))
;; Value is in ST0
(
inst
fstd
(
make-ea
:dword
:base
object
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:word-bytes
)
(
*
32
index
))
vm:other-pointer-type
)))
(
unless
(
zerop
(
tn-offset
result-real
))
;; Value is in ST0 but not result.
(
inst
fstd
result-real
)))
(
t
(
inst
li
temp
offset
)
(
inst
stdf
value-real
object
temp
)
(
inst
add
temp
8
)
(
inst
stdf
value-imag
object
temp
)))
(
unless
(
location=
result-real
value-real
)
(
move-double-reg
result-real
value-real
))
(
unless
(
location=
result-imag
value-imag
)
(
move-double-reg
result-imag
value-imag
)))
;; Value is not in ST0.
(
inst
fxch
value-real
)
(
inst
fstd
(
make-ea
:dword
:base
object
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:word-bytes
)
(
*
32
index
))
vm:other-pointer-type
)))
(
cond
((
zerop
(
tn-offset
result-real
))
;; The result is in ST0.
(
inst
fstd
value-real
))
(
t
;; Neither value or result are in ST0
(
unless
(
location=
value-real
result-real
)
(
inst
fstd
result-real
))
(
inst
fxch
value-real
))))))
(
let
((
value-real
(
complex-double-double-reg-real-lo-tn
value
))
(
result-real
(
complex-double-double-reg-real-lo-tn
result
))
(
value-imag
(
complex-double-double-reg-imag-lo-tn
value
))
(
result-imag
(
complex-double-double-reg-imag-lo-tn
result
))
(
offset
(
+
(
*
index
16
)
(
-
(
*
vm:vector-data-offset
vm:word-bytes
)
vm:other-pointer-type
))))
;; There's a possible optimization here if the offset for the
;; real part fits in a signed-byte 13 but the imag part doesn't.
;; We don't do this because it can't happen with the current
;; values of vm:other-pointer-type and vm:vector-data-offset.
(
cond
((
typep
(
+
offset
(
*
6
vm:word-bytes
))
'
(
signed-byte
13
))
(
inst
stdf
value-real
object
(
+
offset
(
*
4
vm:word-bytes
)))
(
inst
stdf
value-imag
object
(
+
offset
(
*
6
vm:word-bytes
))))
(
result-real
(
complex-double-double-reg-real-lo-tn
result
)))
(
cond
((
zerop
(
tn-offset
value-real
))
;; Value is in ST0
(
inst
fstd
(
make-ea
:dword
:base
object
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:word-bytes
)
(
*
32
index
)
8
)
vm:other-pointer-type
)))
(
unless
(
zerop
(
tn-offset
result-real
))
;; Value is in ST0 but not result.
(
inst
fstd
result-real
)))
(
t
(
inst
add
temp
8
)
(
inst
stdf
value-real
object
temp
)
(
inst
add
temp
8
)
(
inst
stdf
value-imag
object
temp
)))
(
unless
(
location=
result-real
value-real
)
(
move-double-reg
result-real
value-real
))
(
unless
(
location=
result-imag
value-imag
)
(
move-double-reg
result-imag
value-imag
)))))
;; Value is not in ST0.
(
inst
fxch
value-real
)
(
inst
fstd
(
make-ea
:dword
:base
object
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:word-bytes
)
(
*
32
index
)
8
)
vm:other-pointer-type
)))
(
cond
((
zerop
(
tn-offset
result-real
))
;; The result is in ST0.
(
inst
fstd
value-real
))
(
t
;; Neither value or result are in ST0
(
unless
(
location=
value-real
result-real
)
(
inst
fstd
result-real
))
(
inst
fxch
value-real
))))))
(
let
((
value-imag
(
complex-double-double-reg-imag-hi-tn
value
))
(
result-imag
(
complex-double-double-reg-imag-hi-tn
result
)))
(
inst
fxch
value-imag
)
(
inst
fstd
(
make-ea
:dword
:base
object
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:word-bytes
)
(
*
32
index
)
16
)
vm:other-pointer-type
)))
(
unless
(
location=
value-imag
result-imag
)
(
inst
fstd
result-imag
))
(
inst
fxch
value-imag
))
(
let
((
value-imag
(
complex-double-double-reg-imag-lo-tn
value
))
(
result-imag
(
complex-double-double-reg-imag-lo-tn
result
)))
(
inst
fxch
value-imag
)
(
inst
fstd
(
make-ea
:dword
:base
object
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:word-bytes
)
(
*
32
index
)
24
)
vm:other-pointer-type
)))
(
unless
(
location=
value-imag
result-imag
)
(
inst
fstd
result-imag
))
(
inst
fxch
value-imag
))))
)
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