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
Container 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
This is an archived project. Repository and other project resources are read-only.
Show more breadcrumbs
Jon Boone
cmucl
Commits
dcaac995
Commit
dcaac995
authored
11 years ago
by
Carl Shapiro
Browse files
Options
Downloads
Patches
Plain Diff
Allow any unsigned-reg for the check-type and type-predicate temporary.
parent
b90e144d
No related branches found
Branches containing commit
No related tags found
Tags containing commit
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
src/compiler/x86/type-vops.lisp
+74
-74
74 additions, 74 deletions
src/compiler/x86/type-vops.lisp
with
74 additions
and
74 deletions
src/compiler/x86/type-vops.lisp
+
74
−
74
View file @
dcaac995
...
...
@@ -60,7 +60,7 @@
(
emit-test
)))
(
results
)))
(
defmacro
test-type
(
value
target
not-p
&rest
type-codes
)
(
defmacro
test-type
(
value
temp
target
not-p
&rest
type-codes
)
;; Determine what interesting combinations we need to test for.
(
let*
((
type-codes
(
mapcar
#'
eval
type-codes
))
(
fixnump
(
and
(
member
even-fixnum-type
type-codes
)
...
...
@@ -90,7 +90,7 @@
(
when
immediates
(
error
"Can't mix fixnum testing with other immediates."
))
(
if
headers
`
(
%test-fixnum-and-headers
,
value
,
target
,
not-p
`
(
%test-fixnum-and-headers
,
value
,
temp
,
target
,
not-p
',
(
canonicalize-headers
headers
))
`
(
%test-fixnum
,
value
,
target
,
not-p
)))
(
immediates
...
...
@@ -100,17 +100,17 @@
(
error
"Can't mix testing of immediates with testing of lowtags."
))
(
when
(
cdr
immediates
)
(
error
"Can't test multiple immediates at the same time."
))
`
(
%test-immediate
,
value
,
target
,
not-p
,
(
car
immediates
)))
`
(
%test-immediate
,
value
,
temp
,
target
,
not-p
,
(
car
immediates
)))
(
lowtags
(
when
(
cdr
lowtags
)
(
error
"Can't test multiple lowtags at the same time."
))
(
if
headers
`
(
%test-lowtag-and-headers
,
value
,
target
,
not-p
,
(
car
lowtags
)
,
value
,
temp
,
target
,
not-p
,
(
car
lowtags
)
,
function-p
',
(
canonicalize-headers
headers
))
`
(
%test-lowtag
,
value
,
target
,
not-p
,
(
car
lowtags
))))
`
(
%test-lowtag
,
value
,
temp
,
target
,
not-p
,
(
car
lowtags
))))
(
headers
`
(
%test-headers
,
value
,
target
,
not-p
,
function-p
`
(
%test-headers
,
value
,
temp
,
target
,
not-p
,
function-p
',
(
canonicalize-headers
headers
)))
(
t
(
error
"Nothing to test?"
)))))
...
...
@@ -143,13 +143,13 @@
(
generate-fixnum-test
value
)
(
inst
jmp
(
if
not-p
:nz
:z
)
target
))
(
defun
%test-fixnum-and-headers
(
value
target
not-p
headers
)
(
defun
%test-fixnum-and-headers
(
value
temp
target
not-p
headers
)
(
let
((
drop-through
(
gen-label
)))
(
generate-fixnum-test
value
)
(
inst
jmp
:z
(
if
not-p
drop-through
target
))
(
%test-headers
value
target
not-p
nil
headers
drop-through
)))
(
%test-headers
value
temp
target
not-p
nil
headers
drop-through
)))
(
defun
%test-immediate
(
value
target
not-p
immediate
)
(
defun
%test-immediate
(
value
temp
target
not-p
immediate
)
;; Code a single instruction byte test if possible.
(
let
((
offset
(
tn-offset
value
)))
(
cond
((
and
(
sc-is
value
any-reg
descriptor-reg
)
...
...
@@ -160,25 +160,27 @@
:offset
offset
)
immediate
))
(
t
(
move
eax-tn
value
)
(
inst
cmp
al-tn
immediate
))))
(
move
temp
value
)
(
inst
and
temp
type-mask
)
(
inst
cmp
temp
immediate
))))
(
inst
jmp
(
if
not-p
:ne
:e
)
target
))
(
defun
%test-lowtag
(
value
target
not-p
lowtag
&optional
al
-loaded
)
(
unless
al
-loaded
(
move
eax-tn
value
)
(
inst
and
al-tn
lowtag-mask
))
(
inst
cmp
al-tn
lowtag
)
(
defun
%test-lowtag
(
value
temp
target
not-p
lowtag
&optional
temp
-loaded
)
(
unless
temp
-loaded
(
move
temp
value
)
(
inst
and
temp
lowtag-mask
))
(
inst
cmp
temp
lowtag
)
(
inst
jmp
(
if
not-p
:ne
:e
)
target
))
(
defun
%test-lowtag-and-headers
(
value
target
not-p
lowtag
function-p
headers
)
(
defun
%test-lowtag-and-headers
(
value
temp
target
not-p
lowtag
function-p
headers
)
(
let
((
drop-through
(
gen-label
)))
(
%test-lowtag
value
(
if
not-p
drop-through
target
)
nil
lowtag
)
(
%test-headers
value
target
not-p
function-p
headers
drop-through
t
)))
(
%test-lowtag
value
temp
(
if
not-p
drop-through
target
)
nil
lowtag
)
(
%test-headers
value
temp
target
not-p
function-p
headers
drop-through
t
)))
(
defun
%test-headers
(
value
target
not-p
function-p
headers
&optional
(
drop-through
(
gen-label
))
al
-loaded
)
(
defun
%test-headers
(
value
temp
target
not-p
function-p
headers
&optional
(
drop-through
(
gen-label
))
temp
-loaded
)
(
let
((
lowtag
(
if
function-p
function-pointer-type
other-pointer-type
)))
(
multiple-value-bind
(
equal
less-or-equal
when-true
when-false
)
...
...
@@ -188,15 +190,15 @@
(
if
not-p
(
values
:ne
:a
drop-through
target
)
(
values
:e
:na
target
drop-through
))
(
%test-lowtag
value
when-false
t
lowtag
al
-loaded
)
(
inst
mov
al-tn
(
make-ea
:byte
:base
value
:disp
(
-
lowtag
))
)
(
%test-lowtag
value
temp
when-false
t
lowtag
temp
-loaded
)
(
load-type
temp
value
(
-
lowtag
))
(
do
((
remaining
headers
(
cdr
remaining
)))
((
null
remaining
))
(
let
((
header
(
car
remaining
))
(
last
(
null
(
cdr
remaining
))))
(
cond
((
atom
header
)
(
inst
cmp
al-tn
header
)
(
inst
cmp
temp
header
)
(
if
last
(
inst
jmp
equal
target
)
(
inst
jmp
:e
when-true
)))
...
...
@@ -204,9 +206,9 @@
(
let
((
start
(
car
header
))
(
end
(
cdr
header
)))
(
unless
(
=
start
bignum-type
)
(
inst
cmp
al-tn
start
)
(
inst
cmp
temp
start
)
(
inst
jmp
:b
when-false
))
; was :l
(
inst
cmp
al-tn
end
)
(
inst
cmp
temp
end
)
(
if
last
(
inst
jmp
less-or-equal
target
)
(
inst
jmp
:be
when-true
)))))))
; was :le
...
...
@@ -217,7 +219,7 @@
;; both cmp and sub take 2 cycles so maybe its a wash
#+
nil
(
defun
%test-headers
(
value
target
not-p
function-p
headers
&optional
(
drop-through
(
gen-label
))
al
-loaded
)
&optional
(
drop-through
(
gen-label
))
temp
-loaded
)
(
let
((
lowtag
(
if
function-p
function-pointer-type
other-pointer-type
)))
(
multiple-value-bind
(
equal
less-or-equal
when-true
when-false
)
...
...
@@ -227,8 +229,8 @@
(
if
not-p
(
values
:ne
:a
drop-through
target
)
(
values
:e
:na
target
drop-through
))
(
%test-lowtag
value
when-false
t
lowtag
al
-loaded
)
(
inst
mov
al-tn
(
make-ea
:byte
:base
value
:disp
(
-
lowtag
))
)
(
%test-lowtag
value
when-false
t
lowtag
temp
-loaded
)
(
load-type
temp
value
(
-
lowtag
))
(
let
((
delta
0
))
(
do
((
remaining
headers
(
cdr
remaining
)))
((
null
remaining
))
...
...
@@ -236,7 +238,7 @@
(
last
(
null
(
cdr
remaining
))))
(
cond
((
atom
header
)
(
inst
sub
al-tn
(
-
header
delta
))
(
inst
sub
temp
(
-
header
delta
))
(
setf
delta
header
)
(
if
last
(
inst
jmp
equal
target
)
...
...
@@ -245,10 +247,10 @@
(
let
((
start
(
car
header
))
(
end
(
cdr
header
)))
(
unless
(
=
start
bignum-type
)
(
inst
sub
al-tn
(
-
start
delta
))
(
inst
sub
temp
(
-
start
delta
))
(
setf
delta
start
)
(
inst
jmp
:l
when-false
))
(
inst
sub
al-tn
(
-
end
delta
))
(
inst
sub
temp
(
-
end
delta
))
(
setf
delta
end
)
(
if
last
(
inst
jmp
less-or-equal
target
)
...
...
@@ -261,15 +263,13 @@
(
define-vop
(
check-type
)
(
:args
(
value
:target
result
:scs
(
any-reg
descriptor-reg
)))
(
:results
(
result
:scs
(
any-reg
descriptor-reg
)))
(
:temporary
(
:sc
unsigned-reg
:offset
eax-offset
:to
(
:result
0
))
eax
)
(
:ignore
eax
)
(
:temporary
(
:scs
(
unsigned-reg
)
:to
(
:result
0
))
temp
)
(
:vop-var
vop
)
(
:save-p
:compute-only
))
(
define-vop
(
type-predicate
)
(
:args
(
value
:scs
(
any-reg
descriptor-reg
)))
(
:temporary
(
:sc
unsigned-reg
:offset
eax-offset
)
eax
)
(
:ignore
eax
)
(
:temporary
(
:scs
(
unsigned-reg
))
temp
)
(
:conditional
)
(
:info
target
not-p
)
(
:policy
:fast-safe
))
...
...
@@ -303,13 +303,13 @@
`
((
define-vop
(
,
pred-name
type-predicate
)
(
:translate
,
pred-name
)
(
:generator
,
cost
(
test-type
value
target
not-p
,@
type-codes
)))))
(
test-type
value
temp
target
not-p
,@
type-codes
)))))
,@
(
when
check-name
`
((
define-vop
(
,
check-name
check-type
)
(
:generator
,
cost
(
let
((
err-lab
(
generate-error-code
vop
,
error-code
value
)))
(
test-type
value
err-lab
t
,@
type-codes
)
(
test-type
value
temp
err-lab
t
,@
type-codes
)
(
move
result
value
))))))
,@
(
when
ptype
`
((
primitive-type-vop
,
check-name
(
:check
)
,
ptype
))))))
...
...
@@ -322,13 +322,13 @@
`
((
define-vop
(
,
pred-name
simple-type-predicate
)
(
:translate
,
pred-name
)
(
:generator
,
cost
(
test-type
value
target
not-p
,@
type-codes
)))))
(
test-type
value
temp
target
not-p
,@
type-codes
)))))
,@
(
when
check-name
`
((
define-vop
(
,
check-name
simple-check-type
)
(
:generator
,
cost
(
let
((
err-lab
(
generate-error-code
vop
,
error-code
value
)))
(
test-type
value
err-lab
t
,@
type-codes
)
(
test-type
value
temp
err-lab
t
,@
type-codes
)
(
move
result
value
))))))
,@
(
when
ptype
`
((
primitive-type-vop
,
check-name
(
:check
)
,
ptype
))))))
...
...
@@ -634,12 +634,12 @@
(
values
target
not-target
))
(
generate-fixnum-test
value
)
(
inst
jmp
:e
yep
)
(
move
eax-tn
value
)
(
inst
and
al-tn
lowtag-mask
)
(
inst
cmp
al-tn
other-pointer-type
)
(
move
temp
value
)
(
inst
and
temp
lowtag-mask
)
(
inst
cmp
temp
other-pointer-type
)
(
inst
jmp
:ne
nope
)
(
loadw
eax-tn
value
0
other-pointer-type
)
(
inst
cmp
eax-tn
(
+
(
ash
1
type-bits
)
bignum-type
))
(
loadw
temp
value
0
other-pointer-type
)
(
inst
cmp
temp
(
+
(
ash
1
type-bits
)
bignum-type
))
(
inst
jmp
(
if
not-p
:ne
:e
)
target
))
NOT-TARGET
))
...
...
@@ -650,12 +650,12 @@
value
)))
(
generate-fixnum-test
value
)
(
inst
jmp
:e
yep
)
(
move
eax-tn
value
)
(
inst
and
al-tn
lowtag-mask
)
(
inst
cmp
al-tn
other-pointer-type
)
(
move
temp
value
)
(
inst
and
temp
lowtag-mask
)
(
inst
cmp
temp
other-pointer-type
)
(
inst
jmp
:ne
nope
)
(
loadw
eax-tn
value
0
other-pointer-type
)
(
inst
cmp
eax-tn
(
+
(
ash
1
type-bits
)
bignum-type
))
(
loadw
temp
value
0
other-pointer-type
)
(
inst
cmp
temp
(
+
(
ash
1
type-bits
)
bignum-type
))
(
inst
jmp
:ne
nope
))
YEP
(
move
result
value
)))
...
...
@@ -677,35 +677,35 @@
(
values
target
not-target
))
;; Is it a fixnum?
(
generate-fixnum-test
value
)
(
move
eax-tn
value
)
(
move
temp
value
)
(
inst
jmp
:e
fixnum
)
;; If not, is it an other pointer?
(
inst
and
al-tn
lowtag-mask
)
(
inst
cmp
al-tn
other-pointer-type
)
(
inst
and
temp
lowtag-mask
)
(
inst
cmp
temp
other-pointer-type
)
(
inst
jmp
:ne
nope
)
;; Get the header.
(
loadw
eax-tn
value
0
other-pointer-type
)
(
loadw
temp
value
0
other-pointer-type
)
;; Is it one?
(
inst
cmp
eax-tn
(
+
(
ash
1
type-bits
)
bignum-type
))
(
inst
cmp
temp
(
+
(
ash
1
type-bits
)
bignum-type
))
(
inst
jmp
:e
single-word
)
;; If it's other than two, we can't be an (unsigned-byte 32)
(
inst
cmp
eax-tn
(
+
(
ash
2
type-bits
)
bignum-type
))
(
inst
cmp
temp
(
+
(
ash
2
type-bits
)
bignum-type
))
(
inst
jmp
:ne
nope
)
;; Get the second digit.
(
loadw
eax-tn
value
(
1+
bignum-digits-offset
)
other-pointer-type
)
(
loadw
temp
value
(
1+
bignum-digits-offset
)
other-pointer-type
)
;; All zeros, its an (unsigned-byte 32).
(
inst
or
eax-tn
eax-tn
)
(
inst
test
temp
temp
)
(
inst
jmp
:z
yep
)
(
inst
jmp
nope
)
(
emit-label
single-word
)
;; Get the single digit.
(
loadw
eax-tn
value
bignum-digits-offset
other-pointer-type
)
(
loadw
temp
value
bignum-digits-offset
other-pointer-type
)
;; positive implies (unsigned-byte 32).
(
emit-label
fixnum
)
(
inst
or
eax-tn
eax-tn
)
(
inst
test
temp
temp
)
(
inst
jmp
(
if
not-p
:s
:ns
)
target
)
(
emit-label
not-target
)))))
...
...
@@ -720,35 +720,35 @@
;; Is it a fixnum?
(
generate-fixnum-test
value
)
(
move
eax-tn
value
)
(
move
temp
value
)
(
inst
jmp
:e
fixnum
)
;; If not, is it an other pointer?
(
inst
and
al-tn
lowtag-mask
)
(
inst
cmp
al-tn
other-pointer-type
)
(
inst
and
temp
lowtag-mask
)
(
inst
cmp
temp
other-pointer-type
)
(
inst
jmp
:ne
nope
)
;; Get the header.
(
loadw
eax-tn
value
0
other-pointer-type
)
(
loadw
temp
value
0
other-pointer-type
)
;; Is it one?
(
inst
cmp
eax-tn
(
+
(
ash
1
type-bits
)
bignum-type
))
(
inst
cmp
temp
(
+
(
ash
1
type-bits
)
bignum-type
))
(
inst
jmp
:e
single-word
)
;; If it's other than two, we can't be an (unsigned-byte 32)
(
inst
cmp
eax-tn
(
+
(
ash
2
type-bits
)
bignum-type
))
(
inst
cmp
temp
(
+
(
ash
2
type-bits
)
bignum-type
))
(
inst
jmp
:ne
nope
)
;; Get the second digit.
(
loadw
eax-tn
value
(
1+
bignum-digits-offset
)
other-pointer-type
)
(
loadw
temp
value
(
1+
bignum-digits-offset
)
other-pointer-type
)
;; All zeros, its an (unsigned-byte 32).
(
inst
or
eax-tn
eax-tn
)
(
inst
or
temp
temp
)
(
inst
jmp
:z
yep
)
(
inst
jmp
nope
)
(
emit-label
single-word
)
;; Get the single digit.
(
loadw
eax-tn
value
bignum-digits-offset
other-pointer-type
)
(
loadw
temp
value
bignum-digits-offset
other-pointer-type
)
;; positive implies (unsigned-byte 32).
(
emit-label
fixnum
)
(
inst
or
eax-tn
eax-tn
)
(
inst
or
temp
temp
)
(
inst
jmp
:s
nope
)
(
emit-label
yep
)
...
...
@@ -766,7 +766,7 @@
(
let
((
is-symbol-label
(
if
not-p
drop-thru
target
)))
(
inst
cmp
value
nil-value
)
(
inst
jmp
:e
is-symbol-label
)
(
test-type
value
target
not-p
symbol-header-type
))
(
test-type
value
temp
target
not-p
symbol-header-type
))
DROP-THRU
))
(
define-vop
(
check-symbol
check-type
)
...
...
@@ -774,7 +774,7 @@
(
let
((
error
(
generate-error-code
vop
object-not-symbol-error
value
)))
(
inst
cmp
value
nil-value
)
(
inst
jmp
:e
drop-thru
)
(
test-type
value
error
t
symbol-header-type
))
(
test-type
value
temp
error
t
symbol-header-type
))
DROP-THRU
(
move
result
value
)))
...
...
@@ -784,7 +784,7 @@
(
let
((
is-not-cons-label
(
if
not-p
target
drop-thru
)))
(
inst
cmp
value
nil-value
)
(
inst
jmp
:e
is-not-cons-label
)
(
test-type
value
target
not-p
list-pointer-type
))
(
test-type
value
temp
target
not-p
list-pointer-type
))
DROP-THRU
))
(
define-vop
(
check-cons
check-type
)
...
...
@@ -792,5 +792,5 @@
(
let
((
error
(
generate-error-code
vop
object-not-cons-error
value
)))
(
inst
cmp
value
nil-value
)
(
inst
jmp
:e
error
)
(
test-type
value
error
t
list-pointer-type
)
(
test-type
value
temp
error
t
list-pointer-type
)
(
move
result
value
))))
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment