cpu.x86: shifts didn't work if dst != src1; re-organize file a bit
Slava Pestov
parent
3917f404e9
commit
08a2eb74f4
|
|
@ -79,7 +79,7 @@ M: ##phi prepare-insn
|
|||
[ dst>> ] [ inputs>> values ] bi
|
||||
[ eliminate-copy ] with each ;
|
||||
|
||||
: prepare-block ( bb -- )
|
||||
: prepare-block ( bb -- )
|
||||
instructions>> [ prepare-insn ] each ;
|
||||
|
||||
: prepare-coalescing ( cfg -- )
|
||||
|
|
|
|||
|
|
@ -470,3 +470,9 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-
|
|||
1 swap <displaced-alien>
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
||||
! Forgot to two-operand shifts
|
||||
[ 2 0 ] [
|
||||
1 1
|
||||
[ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call
|
||||
] unit-test
|
||||
|
|
@ -156,6 +156,309 @@ M: x86 %fixnum-sub ( label dst src1 src2 -- )
|
|||
M: x86 %fixnum-mul ( label dst src1 src2 -- )
|
||||
int-rep two-operand swap IMUL2 JO ;
|
||||
|
||||
M: x86 %unbox-alien ( dst src -- )
|
||||
alien-offset [+] MOV ;
|
||||
|
||||
M:: x86 %unbox-any-c-ptr ( dst src temp -- )
|
||||
[
|
||||
{ "is-byte-array" "end" "start" } [ define-label ] each
|
||||
dst 0 MOV
|
||||
temp src MOV
|
||||
! We come back here with displaced aliens
|
||||
"start" resolve-label
|
||||
! Is the object f?
|
||||
temp \ f tag-number CMP
|
||||
"end" get JE
|
||||
! Is the object an alien?
|
||||
temp header-offset [+] alien type-number tag-fixnum CMP
|
||||
"is-byte-array" get JNE
|
||||
! If so, load the offset and add it to the address
|
||||
dst temp alien-offset [+] ADD
|
||||
! Now recurse on the underlying alien
|
||||
temp temp underlying-alien-offset [+] MOV
|
||||
"start" get JMP
|
||||
"is-byte-array" resolve-label
|
||||
! Add byte array address to address being computed
|
||||
dst temp ADD
|
||||
! Add an offset to start of byte array's data
|
||||
dst byte-array-offset ADD
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
|
||||
|
||||
:: %allot-alien ( dst displacement base temp -- )
|
||||
dst 4 cells alien temp %allot
|
||||
dst 1 alien@ base MOV ! alien
|
||||
dst 2 alien@ \ f tag-number MOV ! expired
|
||||
dst 3 alien@ displacement MOV ! displacement
|
||||
;
|
||||
|
||||
M:: x86 %box-alien ( dst src temp -- )
|
||||
[
|
||||
"end" define-label
|
||||
dst \ f tag-number MOV
|
||||
src 0 CMP
|
||||
"end" get JE
|
||||
dst src \ f tag-number temp %allot-alien
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M:: x86 %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
|
||||
[
|
||||
"end" define-label
|
||||
"ok" define-label
|
||||
! If displacement is zero, return the base
|
||||
dst base MOV
|
||||
displacement 0 CMP
|
||||
"end" get JE
|
||||
! Quickly use displacement' before its needed for real, as allot temporary
|
||||
dst 4 cells alien displacement' %allot
|
||||
! If base is already a displaced alien, unpack it
|
||||
base' base MOV
|
||||
displacement' displacement MOV
|
||||
base \ f tag-number CMP
|
||||
"ok" get JE
|
||||
base header-offset [+] alien type-number tag-fixnum CMP
|
||||
"ok" get JNE
|
||||
! displacement += base.displacement
|
||||
displacement' base 3 alien@ ADD
|
||||
! base = base.base
|
||||
base' base 1 alien@ MOV
|
||||
"ok" resolve-label
|
||||
dst 1 alien@ base' MOV ! alien
|
||||
dst 2 alien@ \ f tag-number MOV ! expired
|
||||
dst 3 alien@ displacement' MOV ! displacement
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
! The 'small-reg' mess is pretty crappy, but its only used on x86-32.
|
||||
! On x86-64, all registers have 8-bit versions. However, a similar
|
||||
! problem arises for shifts, where the shift count must be in CL, and
|
||||
! so one day I will fix this properly by adding precoloring to the
|
||||
! register allocator.
|
||||
|
||||
HOOK: has-small-reg? cpu ( reg size -- ? )
|
||||
|
||||
CONSTANT: have-byte-regs { EAX ECX EDX EBX }
|
||||
|
||||
M: x86.32 has-small-reg?
|
||||
{
|
||||
{ 8 [ have-byte-regs memq? ] }
|
||||
{ 16 [ drop t ] }
|
||||
{ 32 [ drop t ] }
|
||||
} case ;
|
||||
|
||||
M: x86.64 has-small-reg? 2drop t ;
|
||||
|
||||
: small-reg-that-isn't ( exclude -- reg' )
|
||||
[ have-byte-regs ] dip
|
||||
[ native-version-of ] map
|
||||
'[ _ memq? not ] find nip ;
|
||||
|
||||
: with-save/restore ( reg quot -- )
|
||||
[ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
|
||||
|
||||
:: with-small-register ( dst exclude size quot: ( new-dst -- ) -- )
|
||||
! If the destination register overlaps a small register with
|
||||
! 'size' bits, we call the quot with that. Otherwise, we find a
|
||||
! small register that is not in exclude, and call quot, saving and
|
||||
! restoring the small register.
|
||||
dst size has-small-reg? [ dst quot call ] [
|
||||
exclude small-reg-that-isn't
|
||||
[ quot call ] with-save/restore
|
||||
] if ; inline
|
||||
|
||||
M:: x86 %string-nth ( dst src index temp -- )
|
||||
! We request a small-reg of size 8 since those of size 16 are
|
||||
! a superset.
|
||||
"end" define-label
|
||||
dst { src index temp } 8 [| new-dst |
|
||||
! Load the least significant 7 bits into new-dst.
|
||||
! 8th bit indicates whether we have to load from
|
||||
! the aux vector or not.
|
||||
temp src index [+] LEA
|
||||
new-dst 8-bit-version-of temp string-offset [+] MOV
|
||||
new-dst new-dst 8-bit-version-of MOVZX
|
||||
! Do we have to look at the aux vector?
|
||||
new-dst HEX: 80 CMP
|
||||
"end" get JL
|
||||
! Yes, this is a non-ASCII character. Load aux vector
|
||||
temp src string-aux-offset [+] MOV
|
||||
new-dst temp XCHG
|
||||
! Compute index
|
||||
new-dst index ADD
|
||||
new-dst index ADD
|
||||
! Load high 16 bits
|
||||
new-dst 16-bit-version-of new-dst byte-array-offset [+] MOV
|
||||
new-dst new-dst 16-bit-version-of MOVZX
|
||||
new-dst 7 SHL
|
||||
! Compute code point
|
||||
new-dst temp XOR
|
||||
"end" resolve-label
|
||||
dst new-dst int-rep %copy
|
||||
] with-small-register ;
|
||||
|
||||
M:: x86 %set-string-nth-fast ( ch str index temp -- )
|
||||
ch { index str temp } 8 [| new-ch |
|
||||
new-ch ch int-rep %copy
|
||||
temp str index [+] LEA
|
||||
temp string-offset [+] new-ch 8-bit-version-of MOV
|
||||
] with-small-register ;
|
||||
|
||||
:: %alien-integer-getter ( dst src size quot -- )
|
||||
dst { src } size [| new-dst |
|
||||
new-dst dup size n-bit-version-of dup src [] MOV
|
||||
quot call
|
||||
dst new-dst int-rep %copy
|
||||
] with-small-register ; inline
|
||||
|
||||
: %alien-unsigned-getter ( dst src size -- )
|
||||
[ MOVZX ] %alien-integer-getter ; inline
|
||||
|
||||
M: x86 %alien-unsigned-1 8 %alien-unsigned-getter ;
|
||||
M: x86 %alien-unsigned-2 16 %alien-unsigned-getter ;
|
||||
M: x86 %alien-unsigned-4 32 [ 2drop ] %alien-integer-getter ;
|
||||
|
||||
: %alien-signed-getter ( dst src size -- )
|
||||
[ MOVSX ] %alien-integer-getter ; inline
|
||||
|
||||
M: x86 %alien-signed-1 8 %alien-signed-getter ;
|
||||
M: x86 %alien-signed-2 16 %alien-signed-getter ;
|
||||
M: x86 %alien-signed-4 32 %alien-signed-getter ;
|
||||
|
||||
M: x86 %alien-cell [] MOV ;
|
||||
M: x86 %alien-float [] MOVSS ;
|
||||
M: x86 %alien-double [] MOVSD ;
|
||||
M: x86 %alien-vector [ [] ] dip %copy ;
|
||||
|
||||
:: %alien-integer-setter ( ptr value size -- )
|
||||
value { ptr } size [| new-value |
|
||||
new-value value int-rep %copy
|
||||
ptr [] new-value size n-bit-version-of MOV
|
||||
] with-small-register ; inline
|
||||
|
||||
M: x86 %set-alien-integer-1 8 %alien-integer-setter ;
|
||||
M: x86 %set-alien-integer-2 16 %alien-integer-setter ;
|
||||
M: x86 %set-alien-integer-4 32 %alien-integer-setter ;
|
||||
M: x86 %set-alien-cell [ [] ] dip MOV ;
|
||||
M: x86 %set-alien-float [ [] ] dip MOVSS ;
|
||||
M: x86 %set-alien-double [ [] ] dip MOVSD ;
|
||||
M: x86 %set-alien-vector [ [] ] 2dip %copy ;
|
||||
|
||||
: shift-count? ( reg -- ? ) { ECX RCX } memq? ;
|
||||
|
||||
:: emit-shift ( dst src quot -- )
|
||||
src shift-count? [
|
||||
dst CL quot call
|
||||
] [
|
||||
dst shift-count? [
|
||||
dst src XCHG
|
||||
src CL quot call
|
||||
dst src XCHG
|
||||
] [
|
||||
ECX native-version-of [
|
||||
CL src MOV
|
||||
drop dst CL quot call
|
||||
] with-save/restore
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
M: x86 %shl int-rep two-operand [ SHL ] emit-shift ;
|
||||
M: x86 %shr int-rep two-operand [ SHR ] emit-shift ;
|
||||
M: x86 %sar int-rep two-operand [ SAR ] emit-shift ;
|
||||
|
||||
M: x86 %vm-field-ptr ( dst field -- )
|
||||
[ drop 0 MOV rc-absolute-cell rt-vm rel-fixup ]
|
||||
[ vm-field-offset ADD ] 2bi ;
|
||||
|
||||
: load-zone-ptr ( reg -- )
|
||||
#! Load pointer to start of zone array
|
||||
"nursery" %vm-field-ptr ;
|
||||
|
||||
: load-allot-ptr ( nursery-ptr allot-ptr -- )
|
||||
[ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
|
||||
|
||||
: inc-allot-ptr ( nursery-ptr n -- )
|
||||
[ cell [+] ] dip 8 align ADD ;
|
||||
|
||||
: store-header ( temp class -- )
|
||||
[ [] ] [ type-number tag-fixnum ] bi* MOV ;
|
||||
|
||||
: store-tagged ( dst tag -- )
|
||||
tag-number OR ;
|
||||
|
||||
M:: x86 %allot ( dst size class nursery-ptr -- )
|
||||
nursery-ptr dst load-allot-ptr
|
||||
dst class store-header
|
||||
dst class store-tagged
|
||||
nursery-ptr size inc-allot-ptr ;
|
||||
|
||||
M:: x86 %write-barrier ( src card# table -- )
|
||||
#! Mark the card pointed to by vreg.
|
||||
! Mark the card
|
||||
card# src MOV
|
||||
card# card-bits SHR
|
||||
table "cards_offset" %vm-field-ptr
|
||||
table table [] MOV
|
||||
table card# [+] card-mark <byte> MOV
|
||||
|
||||
! Mark the card deck
|
||||
card# deck-bits card-bits - SHR
|
||||
table "decks_offset" %vm-field-ptr
|
||||
table table [] MOV
|
||||
table card# [+] card-mark <byte> MOV ;
|
||||
|
||||
M:: x86 %check-nursery ( label temp1 temp2 -- )
|
||||
temp1 load-zone-ptr
|
||||
temp2 temp1 cell [+] MOV
|
||||
temp2 1024 ADD
|
||||
temp1 temp1 3 cells [+] MOV
|
||||
temp2 temp1 CMP
|
||||
label JLE ;
|
||||
|
||||
M: x86 %save-gc-root ( gc-root register -- ) [ gc-root@ ] dip MOV ;
|
||||
|
||||
M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ MOV ;
|
||||
|
||||
M: x86 %alien-global ( dst symbol library -- )
|
||||
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
|
||||
|
||||
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
|
||||
|
||||
:: %boolean ( dst temp word -- )
|
||||
dst \ f tag-number MOV
|
||||
temp 0 MOV \ t rc-absolute-cell rel-immediate
|
||||
dst temp word execute ; inline
|
||||
|
||||
M:: x86 %compare ( dst src1 src2 cc temp -- )
|
||||
src1 src2 CMP
|
||||
cc order-cc {
|
||||
{ cc< [ dst temp \ CMOVL %boolean ] }
|
||||
{ cc<= [ dst temp \ CMOVLE %boolean ] }
|
||||
{ cc> [ dst temp \ CMOVG %boolean ] }
|
||||
{ cc>= [ dst temp \ CMOVGE %boolean ] }
|
||||
{ cc= [ dst temp \ CMOVE %boolean ] }
|
||||
{ cc/= [ dst temp \ CMOVNE %boolean ] }
|
||||
} case ;
|
||||
|
||||
M: x86 %compare-imm ( dst src1 src2 cc temp -- )
|
||||
%compare ;
|
||||
|
||||
M:: x86 %compare-branch ( label src1 src2 cc -- )
|
||||
src1 src2 CMP
|
||||
cc order-cc {
|
||||
{ cc< [ label JL ] }
|
||||
{ cc<= [ label JLE ] }
|
||||
{ cc> [ label JG ] }
|
||||
{ cc>= [ label JGE ] }
|
||||
{ cc= [ label JE ] }
|
||||
{ cc/= [ label JNE ] }
|
||||
} case ;
|
||||
|
||||
M: x86 %compare-imm-branch ( label src1 src2 cc -- )
|
||||
%compare-branch ;
|
||||
|
||||
M: x86 %add-float double-rep two-operand ADDSD ;
|
||||
M: x86 %sub-float double-rep two-operand SUBSD ;
|
||||
M: x86 %mul-float double-rep two-operand MULSD ;
|
||||
|
|
@ -177,6 +480,86 @@ M:: x86 %box-float ( dst src temp -- )
|
|||
dst 16 float temp %allot
|
||||
dst float-offset [+] src MOVSD ;
|
||||
|
||||
: %cmov-float= ( dst src -- )
|
||||
[
|
||||
"no-move" define-label
|
||||
|
||||
"no-move" get [ JNE ] [ JP ] bi
|
||||
MOV
|
||||
"no-move" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
: %cmov-float/= ( dst src -- )
|
||||
[
|
||||
"no-move" define-label
|
||||
"move" define-label
|
||||
|
||||
"move" get JP
|
||||
"no-move" get JE
|
||||
"move" resolve-label
|
||||
MOV
|
||||
"no-move" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
:: (%compare-float) ( dst src1 src2 cc temp compare -- )
|
||||
cc {
|
||||
{ cc< [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVA %boolean ] }
|
||||
{ cc<= [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
|
||||
{ cc> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVA %boolean ] }
|
||||
{ cc>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
|
||||
{ cc= [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float= %boolean ] }
|
||||
{ cc<> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNE %boolean ] }
|
||||
{ cc<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNP %boolean ] }
|
||||
{ cc/< [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
|
||||
{ cc/<= [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVB %boolean ] }
|
||||
{ cc/> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
|
||||
{ cc/>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVB %boolean ] }
|
||||
{ cc/= [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float/= %boolean ] }
|
||||
{ cc/<> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVE %boolean ] }
|
||||
{ cc/<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVP %boolean ] }
|
||||
} case ; inline
|
||||
|
||||
M: x86 %compare-float-ordered ( dst src1 src2 cc temp -- )
|
||||
\ COMISD (%compare-float) ;
|
||||
|
||||
M: x86 %compare-float-unordered ( dst src1 src2 cc temp -- )
|
||||
\ UCOMISD (%compare-float) ;
|
||||
|
||||
: %jump-float= ( label -- )
|
||||
[
|
||||
"no-jump" define-label
|
||||
"no-jump" get JP
|
||||
JE
|
||||
"no-jump" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
: %jump-float/= ( label -- )
|
||||
[ JNE ] [ JP ] bi ;
|
||||
|
||||
:: (%compare-float-branch) ( label src1 src2 cc compare -- )
|
||||
cc {
|
||||
{ cc< [ src2 src1 \ compare execute( a b -- ) label JA ] }
|
||||
{ cc<= [ src2 src1 \ compare execute( a b -- ) label JAE ] }
|
||||
{ cc> [ src1 src2 \ compare execute( a b -- ) label JA ] }
|
||||
{ cc>= [ src1 src2 \ compare execute( a b -- ) label JAE ] }
|
||||
{ cc= [ src1 src2 \ compare execute( a b -- ) label %jump-float= ] }
|
||||
{ cc<> [ src1 src2 \ compare execute( a b -- ) label JNE ] }
|
||||
{ cc<>= [ src1 src2 \ compare execute( a b -- ) label JNP ] }
|
||||
{ cc/< [ src2 src1 \ compare execute( a b -- ) label JBE ] }
|
||||
{ cc/<= [ src2 src1 \ compare execute( a b -- ) label JB ] }
|
||||
{ cc/> [ src1 src2 \ compare execute( a b -- ) label JBE ] }
|
||||
{ cc/>= [ src1 src2 \ compare execute( a b -- ) label JB ] }
|
||||
{ cc/= [ src1 src2 \ compare execute( a b -- ) label %jump-float/= ] }
|
||||
{ cc/<> [ src1 src2 \ compare execute( a b -- ) label JE ] }
|
||||
{ cc/<>= [ src1 src2 \ compare execute( a b -- ) label JP ] }
|
||||
} case ;
|
||||
|
||||
M: x86 %compare-float-ordered-branch ( label src1 src2 cc -- )
|
||||
\ COMISD (%compare-float-branch) ;
|
||||
|
||||
M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- )
|
||||
\ UCOMISD (%compare-float-branch) ;
|
||||
|
||||
M:: x86 %box-vector ( dst src rep temp -- )
|
||||
dst rep rep-size 2 cells + byte-array temp %allot
|
||||
16 tag-fixnum dst 1 byte-array tag-number %set-slot-imm
|
||||
|
|
@ -543,390 +926,6 @@ M: x86 %integer>scalar drop MOVD ;
|
|||
|
||||
M: x86 %scalar>integer drop MOVD ;
|
||||
|
||||
M: x86 %unbox-alien ( dst src -- )
|
||||
alien-offset [+] MOV ;
|
||||
|
||||
M:: x86 %unbox-any-c-ptr ( dst src temp -- )
|
||||
[
|
||||
{ "is-byte-array" "end" "start" } [ define-label ] each
|
||||
dst 0 MOV
|
||||
temp src MOV
|
||||
! We come back here with displaced aliens
|
||||
"start" resolve-label
|
||||
! Is the object f?
|
||||
temp \ f tag-number CMP
|
||||
"end" get JE
|
||||
! Is the object an alien?
|
||||
temp header-offset [+] alien type-number tag-fixnum CMP
|
||||
"is-byte-array" get JNE
|
||||
! If so, load the offset and add it to the address
|
||||
dst temp alien-offset [+] ADD
|
||||
! Now recurse on the underlying alien
|
||||
temp temp underlying-alien-offset [+] MOV
|
||||
"start" get JMP
|
||||
"is-byte-array" resolve-label
|
||||
! Add byte array address to address being computed
|
||||
dst temp ADD
|
||||
! Add an offset to start of byte array's data
|
||||
dst byte-array-offset ADD
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
|
||||
|
||||
:: %allot-alien ( dst displacement base temp -- )
|
||||
dst 4 cells alien temp %allot
|
||||
dst 1 alien@ base MOV ! alien
|
||||
dst 2 alien@ \ f tag-number MOV ! expired
|
||||
dst 3 alien@ displacement MOV ! displacement
|
||||
;
|
||||
|
||||
M:: x86 %box-alien ( dst src temp -- )
|
||||
[
|
||||
"end" define-label
|
||||
dst \ f tag-number MOV
|
||||
src 0 CMP
|
||||
"end" get JE
|
||||
dst src \ f tag-number temp %allot-alien
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M:: x86 %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
|
||||
[
|
||||
"end" define-label
|
||||
"ok" define-label
|
||||
! If displacement is zero, return the base
|
||||
dst base MOV
|
||||
displacement 0 CMP
|
||||
"end" get JE
|
||||
! Quickly use displacement' before its needed for real, as allot temporary
|
||||
dst 4 cells alien displacement' %allot
|
||||
! If base is already a displaced alien, unpack it
|
||||
base' base MOV
|
||||
displacement' displacement MOV
|
||||
base \ f tag-number CMP
|
||||
"ok" get JE
|
||||
base header-offset [+] alien type-number tag-fixnum CMP
|
||||
"ok" get JNE
|
||||
! displacement += base.displacement
|
||||
displacement' base 3 alien@ ADD
|
||||
! base = base.base
|
||||
base' base 1 alien@ MOV
|
||||
"ok" resolve-label
|
||||
dst 1 alien@ base' MOV ! alien
|
||||
dst 2 alien@ \ f tag-number MOV ! expired
|
||||
dst 3 alien@ displacement' MOV ! displacement
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
! The 'small-reg' mess is pretty crappy, but its only used on x86-32.
|
||||
! On x86-64, all registers have 8-bit versions. However, a similar
|
||||
! problem arises for shifts, where the shift count must be in CL, and
|
||||
! so one day I will fix this properly by adding precoloring to the
|
||||
! register allocator.
|
||||
|
||||
HOOK: has-small-reg? cpu ( reg size -- ? )
|
||||
|
||||
CONSTANT: have-byte-regs { EAX ECX EDX EBX }
|
||||
|
||||
M: x86.32 has-small-reg?
|
||||
{
|
||||
{ 8 [ have-byte-regs memq? ] }
|
||||
{ 16 [ drop t ] }
|
||||
{ 32 [ drop t ] }
|
||||
} case ;
|
||||
|
||||
M: x86.64 has-small-reg? 2drop t ;
|
||||
|
||||
: small-reg-that-isn't ( exclude -- reg' )
|
||||
[ have-byte-regs ] dip
|
||||
[ native-version-of ] map
|
||||
'[ _ memq? not ] find nip ;
|
||||
|
||||
: with-save/restore ( reg quot -- )
|
||||
[ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
|
||||
|
||||
:: with-small-register ( dst exclude size quot: ( new-dst -- ) -- )
|
||||
! If the destination register overlaps a small register with
|
||||
! 'size' bits, we call the quot with that. Otherwise, we find a
|
||||
! small register that is not in exclude, and call quot, saving and
|
||||
! restoring the small register.
|
||||
dst size has-small-reg? [ dst quot call ] [
|
||||
exclude small-reg-that-isn't
|
||||
[ quot call ] with-save/restore
|
||||
] if ; inline
|
||||
|
||||
M:: x86 %string-nth ( dst src index temp -- )
|
||||
! We request a small-reg of size 8 since those of size 16 are
|
||||
! a superset.
|
||||
"end" define-label
|
||||
dst { src index temp } 8 [| new-dst |
|
||||
! Load the least significant 7 bits into new-dst.
|
||||
! 8th bit indicates whether we have to load from
|
||||
! the aux vector or not.
|
||||
temp src index [+] LEA
|
||||
new-dst 8-bit-version-of temp string-offset [+] MOV
|
||||
new-dst new-dst 8-bit-version-of MOVZX
|
||||
! Do we have to look at the aux vector?
|
||||
new-dst HEX: 80 CMP
|
||||
"end" get JL
|
||||
! Yes, this is a non-ASCII character. Load aux vector
|
||||
temp src string-aux-offset [+] MOV
|
||||
new-dst temp XCHG
|
||||
! Compute index
|
||||
new-dst index ADD
|
||||
new-dst index ADD
|
||||
! Load high 16 bits
|
||||
new-dst 16-bit-version-of new-dst byte-array-offset [+] MOV
|
||||
new-dst new-dst 16-bit-version-of MOVZX
|
||||
new-dst 7 SHL
|
||||
! Compute code point
|
||||
new-dst temp XOR
|
||||
"end" resolve-label
|
||||
dst new-dst int-rep %copy
|
||||
] with-small-register ;
|
||||
|
||||
M:: x86 %set-string-nth-fast ( ch str index temp -- )
|
||||
ch { index str temp } 8 [| new-ch |
|
||||
new-ch ch int-rep %copy
|
||||
temp str index [+] LEA
|
||||
temp string-offset [+] new-ch 8-bit-version-of MOV
|
||||
] with-small-register ;
|
||||
|
||||
:: %alien-integer-getter ( dst src size quot -- )
|
||||
dst { src } size [| new-dst |
|
||||
new-dst dup size n-bit-version-of dup src [] MOV
|
||||
quot call
|
||||
dst new-dst int-rep %copy
|
||||
] with-small-register ; inline
|
||||
|
||||
: %alien-unsigned-getter ( dst src size -- )
|
||||
[ MOVZX ] %alien-integer-getter ; inline
|
||||
|
||||
M: x86 %alien-unsigned-1 8 %alien-unsigned-getter ;
|
||||
M: x86 %alien-unsigned-2 16 %alien-unsigned-getter ;
|
||||
M: x86 %alien-unsigned-4 32 [ 2drop ] %alien-integer-getter ;
|
||||
|
||||
: %alien-signed-getter ( dst src size -- )
|
||||
[ MOVSX ] %alien-integer-getter ; inline
|
||||
|
||||
M: x86 %alien-signed-1 8 %alien-signed-getter ;
|
||||
M: x86 %alien-signed-2 16 %alien-signed-getter ;
|
||||
M: x86 %alien-signed-4 32 %alien-signed-getter ;
|
||||
|
||||
M: x86 %alien-cell [] MOV ;
|
||||
M: x86 %alien-float [] MOVSS ;
|
||||
M: x86 %alien-double [] MOVSD ;
|
||||
M: x86 %alien-vector [ [] ] dip %copy ;
|
||||
|
||||
:: %alien-integer-setter ( ptr value size -- )
|
||||
value { ptr } size [| new-value |
|
||||
new-value value int-rep %copy
|
||||
ptr [] new-value size n-bit-version-of MOV
|
||||
] with-small-register ; inline
|
||||
|
||||
M: x86 %set-alien-integer-1 8 %alien-integer-setter ;
|
||||
M: x86 %set-alien-integer-2 16 %alien-integer-setter ;
|
||||
M: x86 %set-alien-integer-4 32 %alien-integer-setter ;
|
||||
M: x86 %set-alien-cell [ [] ] dip MOV ;
|
||||
M: x86 %set-alien-float [ [] ] dip MOVSS ;
|
||||
M: x86 %set-alien-double [ [] ] dip MOVSD ;
|
||||
M: x86 %set-alien-vector [ [] ] 2dip %copy ;
|
||||
|
||||
: shift-count? ( reg -- ? ) { ECX RCX } memq? ;
|
||||
|
||||
:: emit-shift ( dst src1 src2 quot -- )
|
||||
src2 shift-count? [
|
||||
dst CL quot call
|
||||
] [
|
||||
dst shift-count? [
|
||||
dst src2 XCHG
|
||||
src2 CL quot call
|
||||
dst src2 XCHG
|
||||
] [
|
||||
ECX native-version-of [
|
||||
CL src2 MOV
|
||||
drop dst CL quot call
|
||||
] with-save/restore
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
M: x86 %shl [ SHL ] emit-shift ;
|
||||
M: x86 %shr [ SHR ] emit-shift ;
|
||||
M: x86 %sar [ SAR ] emit-shift ;
|
||||
|
||||
M: x86 %vm-field-ptr ( dst field -- )
|
||||
[ drop 0 MOV rc-absolute-cell rt-vm rel-fixup ]
|
||||
[ vm-field-offset ADD ] 2bi ;
|
||||
|
||||
: load-zone-ptr ( reg -- )
|
||||
#! Load pointer to start of zone array
|
||||
"nursery" %vm-field-ptr ;
|
||||
|
||||
: load-allot-ptr ( nursery-ptr allot-ptr -- )
|
||||
[ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
|
||||
|
||||
: inc-allot-ptr ( nursery-ptr n -- )
|
||||
[ cell [+] ] dip 8 align ADD ;
|
||||
|
||||
: store-header ( temp class -- )
|
||||
[ [] ] [ type-number tag-fixnum ] bi* MOV ;
|
||||
|
||||
: store-tagged ( dst tag -- )
|
||||
tag-number OR ;
|
||||
|
||||
M:: x86 %allot ( dst size class nursery-ptr -- )
|
||||
nursery-ptr dst load-allot-ptr
|
||||
dst class store-header
|
||||
dst class store-tagged
|
||||
nursery-ptr size inc-allot-ptr ;
|
||||
|
||||
|
||||
M:: x86 %write-barrier ( src card# table -- )
|
||||
#! Mark the card pointed to by vreg.
|
||||
! Mark the card
|
||||
card# src MOV
|
||||
card# card-bits SHR
|
||||
table "cards_offset" %vm-field-ptr
|
||||
table table [] MOV
|
||||
table card# [+] card-mark <byte> MOV
|
||||
|
||||
! Mark the card deck
|
||||
card# deck-bits card-bits - SHR
|
||||
table "decks_offset" %vm-field-ptr
|
||||
table table [] MOV
|
||||
table card# [+] card-mark <byte> MOV ;
|
||||
|
||||
M:: x86 %check-nursery ( label temp1 temp2 -- )
|
||||
temp1 load-zone-ptr
|
||||
temp2 temp1 cell [+] MOV
|
||||
temp2 1024 ADD
|
||||
temp1 temp1 3 cells [+] MOV
|
||||
temp2 temp1 CMP
|
||||
label JLE ;
|
||||
|
||||
M: x86 %save-gc-root ( gc-root register -- ) [ gc-root@ ] dip MOV ;
|
||||
|
||||
M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ MOV ;
|
||||
|
||||
M: x86 %alien-global ( dst symbol library -- )
|
||||
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
|
||||
|
||||
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
|
||||
|
||||
:: %boolean ( dst temp word -- )
|
||||
dst \ f tag-number MOV
|
||||
temp 0 MOV \ t rc-absolute-cell rel-immediate
|
||||
dst temp word execute ; inline
|
||||
|
||||
M:: x86 %compare ( dst src1 src2 cc temp -- )
|
||||
src1 src2 CMP
|
||||
cc order-cc {
|
||||
{ cc< [ dst temp \ CMOVL %boolean ] }
|
||||
{ cc<= [ dst temp \ CMOVLE %boolean ] }
|
||||
{ cc> [ dst temp \ CMOVG %boolean ] }
|
||||
{ cc>= [ dst temp \ CMOVGE %boolean ] }
|
||||
{ cc= [ dst temp \ CMOVE %boolean ] }
|
||||
{ cc/= [ dst temp \ CMOVNE %boolean ] }
|
||||
} case ;
|
||||
|
||||
M: x86 %compare-imm ( dst src1 src2 cc temp -- )
|
||||
%compare ;
|
||||
|
||||
: %cmov-float= ( dst src -- )
|
||||
[
|
||||
"no-move" define-label
|
||||
|
||||
"no-move" get [ JNE ] [ JP ] bi
|
||||
MOV
|
||||
"no-move" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
: %cmov-float/= ( dst src -- )
|
||||
[
|
||||
"no-move" define-label
|
||||
"move" define-label
|
||||
|
||||
"move" get JP
|
||||
"no-move" get JE
|
||||
"move" resolve-label
|
||||
MOV
|
||||
"no-move" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
:: (%compare-float) ( dst src1 src2 cc temp compare -- )
|
||||
cc {
|
||||
{ cc< [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVA %boolean ] }
|
||||
{ cc<= [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
|
||||
{ cc> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVA %boolean ] }
|
||||
{ cc>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
|
||||
{ cc= [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float= %boolean ] }
|
||||
{ cc<> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNE %boolean ] }
|
||||
{ cc<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNP %boolean ] }
|
||||
{ cc/< [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
|
||||
{ cc/<= [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVB %boolean ] }
|
||||
{ cc/> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
|
||||
{ cc/>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVB %boolean ] }
|
||||
{ cc/= [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float/= %boolean ] }
|
||||
{ cc/<> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVE %boolean ] }
|
||||
{ cc/<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVP %boolean ] }
|
||||
} case ; inline
|
||||
|
||||
M: x86 %compare-float-ordered ( dst src1 src2 cc temp -- )
|
||||
\ COMISD (%compare-float) ;
|
||||
|
||||
M: x86 %compare-float-unordered ( dst src1 src2 cc temp -- )
|
||||
\ UCOMISD (%compare-float) ;
|
||||
|
||||
M:: x86 %compare-branch ( label src1 src2 cc -- )
|
||||
src1 src2 CMP
|
||||
cc order-cc {
|
||||
{ cc< [ label JL ] }
|
||||
{ cc<= [ label JLE ] }
|
||||
{ cc> [ label JG ] }
|
||||
{ cc>= [ label JGE ] }
|
||||
{ cc= [ label JE ] }
|
||||
{ cc/= [ label JNE ] }
|
||||
} case ;
|
||||
|
||||
M: x86 %compare-imm-branch ( label src1 src2 cc -- )
|
||||
%compare-branch ;
|
||||
|
||||
: %jump-float= ( label -- )
|
||||
[
|
||||
"no-jump" define-label
|
||||
"no-jump" get JP
|
||||
JE
|
||||
"no-jump" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
: %jump-float/= ( label -- )
|
||||
[ JNE ] [ JP ] bi ;
|
||||
|
||||
:: (%compare-float-branch) ( label src1 src2 cc compare -- )
|
||||
cc {
|
||||
{ cc< [ src2 src1 \ compare execute( a b -- ) label JA ] }
|
||||
{ cc<= [ src2 src1 \ compare execute( a b -- ) label JAE ] }
|
||||
{ cc> [ src1 src2 \ compare execute( a b -- ) label JA ] }
|
||||
{ cc>= [ src1 src2 \ compare execute( a b -- ) label JAE ] }
|
||||
{ cc= [ src1 src2 \ compare execute( a b -- ) label %jump-float= ] }
|
||||
{ cc<> [ src1 src2 \ compare execute( a b -- ) label JNE ] }
|
||||
{ cc<>= [ src1 src2 \ compare execute( a b -- ) label JNP ] }
|
||||
{ cc/< [ src2 src1 \ compare execute( a b -- ) label JBE ] }
|
||||
{ cc/<= [ src2 src1 \ compare execute( a b -- ) label JB ] }
|
||||
{ cc/> [ src1 src2 \ compare execute( a b -- ) label JBE ] }
|
||||
{ cc/>= [ src1 src2 \ compare execute( a b -- ) label JB ] }
|
||||
{ cc/= [ src1 src2 \ compare execute( a b -- ) label %jump-float/= ] }
|
||||
{ cc/<> [ src1 src2 \ compare execute( a b -- ) label JE ] }
|
||||
{ cc/<>= [ src1 src2 \ compare execute( a b -- ) label JP ] }
|
||||
} case ;
|
||||
|
||||
M: x86 %compare-float-ordered-branch ( label src1 src2 cc -- )
|
||||
\ COMISD (%compare-float-branch) ;
|
||||
|
||||
M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- )
|
||||
\ UCOMISD (%compare-float-branch) ;
|
||||
|
||||
M:: x86 %spill ( src rep dst -- ) dst src rep %copy ;
|
||||
M:: x86 %reload ( dst rep src -- ) dst src rep %copy ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue