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
17 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
Branches
Branches containing commit
Tags
Tags containing commit
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 @@
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
;;;
(
ext:file-comment
(
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 @@
...
@@ -1590,7 +1590,6 @@
(
:arg-types
simple-array-double-double-float
positive-fixnum
)
(
:arg-types
simple-array-double-double-float
positive-fixnum
)
(
:results
(
value
:scs
(
double-double-reg
)))
(
:results
(
value
:scs
(
double-double-reg
)))
(
:result-types
double-double-float
)
(
:result-types
double-double-float
)
;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
(
:generator
7
(
:generator
7
(
let
((
hi-tn
(
double-double-reg-hi-tn
value
)))
(
let
((
hi-tn
(
double-double-reg-hi-tn
value
)))
(
with-empty-tn@fp-top
(
hi-tn
)
(
with-empty-tn@fp-top
(
hi-tn
)
...
@@ -1604,7 +1603,6 @@
...
@@ -1604,7 +1603,6 @@
8
)
8
)
vm:other-pointer-type
)))))))
vm:other-pointer-type
)))))))
#+
nil
(
define-vop
(
data-vector-ref-c/simple-array-double-double-float
)
(
define-vop
(
data-vector-ref-c/simple-array-double-double-float
)
(
:note
"inline array access"
)
(
:note
"inline array access"
)
(
:translate
data-vector-ref
)
(
:translate
data-vector-ref
)
...
@@ -1614,21 +1612,20 @@
...
@@ -1614,21 +1612,20 @@
(
:info
index
)
(
:info
index
)
(
:results
(
value
:scs
(
double-double-reg
)))
(
:results
(
value
:scs
(
double-double-reg
)))
(
:result-types
double-double-float
)
(
:result-types
double-double-float
)
;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
(
:generator
5
(
:generator
5
(
let
((
offset
(
+
(
*
index
16
)
(
let
((
hi-tn
(
double-double-reg-hi-tn
value
))
)
(
-
(
*
vm:vector-data-offset
vm:word-bytes
)
(
with-empty-tn@fp-top
(
hi-tn
)
vm:other-pointer-type
)))
(
inst
fldd
(
make-ea
:dword
:base
object
(
hi-tn
(
double-double-reg-hi-tn
value
)
)
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:word-bytes
)
(
lo-tn
(
double-double-reg-lo-tn
value
)
))
(
*
16
index
))
(
cond
((
typep
(
+
offset
8
)
'
(
signed-byte
13
))
vm:other-pointer-type
)))
))
(
inst
lddf
hi-tn
object
offset
)
(
let
((
lo-tn
(
double-double-reg-lo-tn
value
))
)
(
inst
lddf
lo-tn
object
(
+
offset
8
))
)
(
with-empty-tn@fp-top
(
lo-tn
)
(
t
(
inst
fldd
(
make-ea
:dword
:base
objec
t
(
inst
li
temp
offset
)
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:word-bytes
)
(
inst
lddf
hi-tn
object
temp
)
(
*
16
index
)
(
inst
add
temp
(
*
2
vm:word-bytes
)
)
8
)
(
inst
lddf
lo-tn
object
temp
))))))
vm:other-pointer-type
)
))))))
(
define-vop
(
data-vector-set/simple-array-double-double-float
)
(
define-vop
(
data-vector-set/simple-array-double-double-float
)
(
:note
"inline array store"
)
(
:note
"inline array store"
)
...
@@ -1641,7 +1638,6 @@
...
@@ -1641,7 +1638,6 @@
double-double-float
)
double-double-float
)
(
:results
(
result
:scs
(
double-double-reg
)))
(
:results
(
result
:scs
(
double-double-reg
)))
(
:result-types
double-double-float
)
(
:result-types
double-double-float
)
;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
(
:generator
20
(
:generator
20
(
let
((
value-real
(
double-double-reg-hi-tn
value
))
(
let
((
value-real
(
double-double-reg-hi-tn
value
))
(
result-real
(
double-double-reg-hi-tn
result
)))
(
result-real
(
double-double-reg-hi-tn
result
)))
...
@@ -1680,7 +1676,6 @@
...
@@ -1680,7 +1676,6 @@
(
inst
fstd
result-imag
))
(
inst
fstd
result-imag
))
(
inst
fxch
value-imag
))))
(
inst
fxch
value-imag
))))
#+
nil
(
define-vop
(
data-vector-set-c/simple-array-double-double-float
)
(
define-vop
(
data-vector-set-c/simple-array-double-double-float
)
(
:note
"inline array store"
)
(
:note
"inline array store"
)
(
:translate
data-vector-set
)
(
:translate
data-vector-set
)
...
@@ -1693,31 +1688,46 @@
...
@@ -1693,31 +1688,46 @@
(
:info
index
)
(
:info
index
)
(
:results
(
result
:scs
(
double-double-reg
)))
(
:results
(
result
:scs
(
double-double-reg
)))
(
:result-types
double-double-float
)
(
:result-types
double-double-float
)
;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
(
:generator
20
(
:generator
15
(
let
((
value-real
(
double-double-reg-hi-tn
value
))
(
let
((
value-hi
(
double-double-reg-hi-tn
value
))
(
result-real
(
double-double-reg-hi-tn
result
)))
(
result-hi
(
double-double-reg-hi-tn
result
))
(
cond
((
zerop
(
tn-offset
value-real
))
(
value-lo
(
double-double-reg-lo-tn
value
))
;; Value is in ST0
(
result-lo
(
double-double-reg-lo-tn
result
))
(
inst
fstd
(
make-ea
:dword
:base
object
(
offset
(
+
(
*
index
16
)
:disp
(
-
(
+
(
*
vm:vector-data-offset
(
-
(
*
vm:vector-data-offset
vm:word-bytes
)
vm:word-bytes
)
vm:other-pointer-type
))))
(
*
16
index
))
;; There's a possible optimization here if the offset for the
vm:other-pointer-type
)))
;; real part fits in a signed-byte 13 but the imag part doesn't.
(
unless
(
zerop
(
tn-offset
result-real
))
;; We don't do this because it can't happen with the current
;; Value is in ST0 but not result.
;; values of vm:other-pointer-type and vm:vector-data-offset.
(
inst
fstd
result-real
)))
(
cond
((
typep
(
+
offset
8
)
'
(
signed-byte
13
))
(
inst
stdf
value-hi
object
offset
)
(
inst
stdf
value-lo
object
(
+
offset
8
)))
(
t
(
t
(
inst
li
temp
offset
)
;; Value is not in ST0.
(
inst
stdf
value-hi
object
temp
)
(
inst
fxch
value-real
)
(
inst
add
temp
8
)
(
inst
fstd
(
make-ea
:dword
:base
object
(
inst
stdf
value-lo
object
temp
)))
:disp
(
-
(
+
(
*
vm:vector-data-offset
(
unless
(
location=
result-hi
value-hi
)
vm:word-bytes
)
(
move-double-reg
result-hi
value-hi
))
(
*
16
index
))
(
unless
(
location=
result-lo
value-lo
)
vm:other-pointer-type
)))
(
move-double-reg
result-lo
value-lo
)))))
(
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
)
(
define-vop
(
data-vector-ref/simple-array-complex-double-double-float
)
(
:note
"inline array access"
)
(
:note
"inline array access"
)
...
@@ -1728,7 +1738,6 @@
...
@@ -1728,7 +1738,6 @@
(
:arg-types
simple-array-complex-double-double-float
positive-fixnum
)
(
:arg-types
simple-array-complex-double-double-float
positive-fixnum
)
(
:results
(
value
:scs
(
complex-double-double-reg
)))
(
:results
(
value
:scs
(
complex-double-double-reg
)))
(
:result-types
complex-double-double-float
)
(
:result-types
complex-double-double-float
)
;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
(
:generator
7
(
:generator
7
(
let
((
real-tn
(
complex-double-double-reg-real-hi-tn
value
)))
(
let
((
real-tn
(
complex-double-double-reg-real-hi-tn
value
)))
(
with-empty-tn@fp-top
(
real-tn
)
(
with-empty-tn@fp-top
(
real-tn
)
...
@@ -1754,7 +1763,6 @@
...
@@ -1754,7 +1763,6 @@
24
)
24
)
vm:other-pointer-type
)))))))
vm:other-pointer-type
)))))))
#+
nil
(
define-vop
(
data-vector-ref-c/simple-array-complex-double-double-float
)
(
define-vop
(
data-vector-ref-c/simple-array-complex-double-double-float
)
(
:note
"inline array access"
)
(
:note
"inline array access"
)
(
:translate
data-vector-ref
)
(
:translate
data-vector-ref
)
...
@@ -1764,28 +1772,34 @@
...
@@ -1764,28 +1772,34 @@
(
:info
index
)
(
:info
index
)
(
:results
(
value
:scs
(
complex-double-double-reg
)))
(
:results
(
value
:scs
(
complex-double-double-reg
)))
(
:result-types
complex-double-double-float
)
(
:result-types
complex-double-double-float
)
;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
(
:generator
5
(
:generator
5
(
let
((
offset
(
+
(
*
index
16
)
(
let
((
real-tn
(
complex-double-double-reg-real-hi-tn
value
)))
(
-
(
*
vm:vector-data-offset
vm:word-bytes
)
(
with-empty-tn@fp-top
(
real-tn
)
vm:other-pointer-type
)))
(
inst
fldd
(
make-ea
:dword
:base
object
(
real-hi-tn
(
complex-double-double-reg-real-hi-tn
value
))
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:word-bytes
)
(
imag-hi-tn
(
complex-double-double-reg-imag-hi-tn
value
))
(
*
32
index
))
(
real-lo-tn
(
complex-double-double-reg-real-lo-tn
value
))
vm:other-pointer-type
)))))
(
imag-lo-tn
(
complex-double-double-reg-imag-lo-tn
value
)))
(
let
((
real-tn
(
complex-double-double-reg-real-lo-tn
value
)))
(
cond
((
typep
(
+
offset
8
)
'
(
signed-byte
13
))
(
with-empty-tn@fp-top
(
real-tn
)
(
inst
lddf
real-hi-tn
object
offset
)
(
inst
fldd
(
make-ea
:dword
:base
object
(
inst
lddf
imag-hi-tn
object
(
+
offset
(
*
2
vm:word-bytes
)))
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:word-bytes
)
(
inst
lddf
real-lo-tn
object
(
+
offset
(
*
4
vm:word-bytes
)))
(
*
32
index
)
(
inst
lddf
real-lo-tn
object
(
+
offset
(
*
6
vm:word-bytes
))))
8
)
(
t
vm:other-pointer-type
)))))
(
inst
li
temp
offset
)
(
let
((
imag-tn
(
complex-double-double-reg-imag-hi-tn
value
)))
(
inst
lddf
real-hi-tn
object
temp
)
(
with-empty-tn@fp-top
(
imag-tn
)
(
inst
add
temp
(
*
2
vm:word-bytes
))
(
inst
fldd
(
make-ea
:dword
:base
object
(
inst
lddf
imag-hi-tn
object
temp
)
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:word-bytes
)
(
inst
lddf
real-lo-tn
object
temp
)
(
*
32
index
)
(
inst
add
temp
(
*
2
vm:word-bytes
))
16
)
(
inst
lddf
imag-lo-tn
object
temp
))))))
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
)
(
define-vop
(
data-vector-set/simple-array-complex-double-double-float
)
(
:note
"inline array store"
)
(
:note
"inline array store"
)
...
@@ -1798,7 +1812,6 @@
...
@@ -1798,7 +1812,6 @@
complex-double-double-float
)
complex-double-double-float
)
(
:results
(
result
:scs
(
complex-double-double-reg
)))
(
:results
(
result
:scs
(
complex-double-double-reg
)))
(
:result-types
complex-double-double-float
)
(
:result-types
complex-double-double-float
)
;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
(
:generator
20
(
:generator
20
(
let
((
value-real
(
complex-double-double-reg-real-hi-tn
value
))
(
let
((
value-real
(
complex-double-double-reg-real-hi-tn
value
))
(
result-real
(
complex-double-double-reg-real-hi-tn
result
)))
(
result-real
(
complex-double-double-reg-real-hi-tn
result
)))
...
@@ -1875,7 +1888,6 @@
...
@@ -1875,7 +1888,6 @@
(
inst
fstd
result-imag
))
(
inst
fstd
result-imag
))
(
inst
fxch
value-imag
))))
(
inst
fxch
value-imag
))))
#+
nil
(
define-vop
(
data-vector-set-c/simple-array-complex-double-double-float
)
(
define-vop
(
data-vector-set-c/simple-array-complex-double-double-float
)
(
:note
"inline array store"
)
(
:note
"inline array store"
)
(
:translate
data-vector-set
)
(
:translate
data-vector-set
)
...
@@ -1888,53 +1900,86 @@
...
@@ -1888,53 +1900,86 @@
(
:info
index
)
(
:info
index
)
(
:results
(
result
:scs
(
complex-double-double-reg
)))
(
:results
(
result
:scs
(
complex-double-double-reg
)))
(
:result-types
complex-double-double-float
)
(
:result-types
complex-double-double-float
)
;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
(
:generator
20
(
:generator
15
(
let
((
value-real
(
complex-double-double-reg-real-hi-tn
value
))
(
let
((
value-real
(
complex-double-double-reg-real-hi-tn
value
))
(
result-real
(
complex-double-double-reg-real-hi-tn
result
))
(
result-real
(
complex-double-double-reg-real-hi-tn
result
)))
(
value-imag
(
complex-double-double-reg-imag-hi-tn
value
))
(
cond
((
zerop
(
tn-offset
value-real
))
(
result-imag
(
complex-double-double-reg-imag-hi-tn
result
))
;; Value is in ST0
(
offset
(
+
(
*
index
16
)
(
inst
fstd
(
make-ea
:dword
:base
object
(
-
(
*
vm:vector-data-offset
vm:word-bytes
)
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:other-pointer-type
))))
vm:word-bytes
)
;; There's a possible optimization here if the offset for the
(
*
32
index
))
;; real part fits in a signed-byte 13 but the imag part doesn't.
vm:other-pointer-type
)))
;; We don't do this because it can't happen with the current
(
unless
(
zerop
(
tn-offset
result-real
))
;; values of vm:other-pointer-type and vm:vector-data-offset.
;; Value is in ST0 but not result.
(
cond
((
typep
(
+
offset
8
)
'
(
signed-byte
13
))
(
inst
fstd
result-real
)))
(
inst
stdf
value-real
object
offset
)
(
inst
stdf
value-imag
object
(
+
offset
8
)))
(
t
(
t
(
inst
li
temp
offset
)
;; Value is not in ST0.
(
inst
stdf
value-real
object
temp
)
(
inst
fxch
value-real
)
(
inst
add
temp
8
)
(
inst
fstd
(
make-ea
:dword
:base
object
(
inst
stdf
value-imag
object
temp
)))
:disp
(
-
(
+
(
*
vm:vector-data-offset
(
unless
(
location=
result-real
value-real
)
vm:word-bytes
)
(
move-double-reg
result-real
value-real
))
(
*
32
index
))
(
unless
(
location=
result-imag
value-imag
)
vm:other-pointer-type
)))
(
move-double-reg
result-imag
value-imag
)))
(
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
))
(
let
((
value-real
(
complex-double-double-reg-real-lo-tn
value
))
(
result-real
(
complex-double-double-reg-real-lo-tn
result
))
(
result-real
(
complex-double-double-reg-real-lo-tn
result
)))
(
value-imag
(
complex-double-double-reg-imag-lo-tn
value
))
(
cond
((
zerop
(
tn-offset
value-real
))
(
result-imag
(
complex-double-double-reg-imag-lo-tn
result
))
;; Value is in ST0
(
offset
(
+
(
*
index
16
)
(
inst
fstd
(
make-ea
:dword
:base
object
(
-
(
*
vm:vector-data-offset
vm:word-bytes
)
:disp
(
-
(
+
(
*
vm:vector-data-offset
vm:other-pointer-type
))))
vm:word-bytes
)
;; There's a possible optimization here if the offset for the
(
*
32
index
)
;; real part fits in a signed-byte 13 but the imag part doesn't.
8
)
;; We don't do this because it can't happen with the current
vm:other-pointer-type
)))
;; values of vm:other-pointer-type and vm:vector-data-offset.
(
unless
(
zerop
(
tn-offset
result-real
))
(
cond
((
typep
(
+
offset
(
*
6
vm:word-bytes
))
'
(
signed-byte
13
))
;; Value is in ST0 but not result.
(
inst
stdf
value-real
object
(
+
offset
(
*
4
vm:word-bytes
)))
(
inst
fstd
result-real
)))
(
inst
stdf
value-imag
object
(
+
offset
(
*
6
vm:word-bytes
))))
(
t
(
t
(
inst
add
temp
8
)
;; Value is not in ST0.
(
inst
stdf
value-real
object
temp
)
(
inst
fxch
value-real
)
(
inst
add
temp
8
)
(
inst
fstd
(
make-ea
:dword
:base
object
(
inst
stdf
value-imag
object
temp
)))
:disp
(
-
(
+
(
*
vm:vector-data-offset
(
unless
(
location=
result-real
value-real
)
vm:word-bytes
)
(
move-double-reg
result-real
value-real
))
(
*
32
index
)
(
unless
(
location=
result-imag
value-imag
)
8
)
(
move-double-reg
result-imag
value-imag
)))))
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