Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
cmucl
cmucl
Commits
dcaac995
Commit
dcaac995
authored
Aug 08, 2013
by
Carl Shapiro
Browse files
Allow any unsigned-reg for the check-type and type-predicate temporary.
parent
b90e144d
Changes
1
Hide whitespace changes
Inline
Side-by-side
src/compiler/x86/type-vops.lisp
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
))))
Write
Preview
Supports
Markdown
0%
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!
Cancel
Please
register
or
sign in
to comment