First approximation at x86 intrinsic definitions
slava
parent
cad17564ad
commit
706c5d825a
|
|
@ -1,221 +1,270 @@
|
||||||
! Copyright (C) 2005, 2006 Slava Pestov.
|
! Copyright (C) 2005, 2006 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
IN: compiler
|
IN: compiler
|
||||||
|
USING: alien assembler kernel kernel-internals math
|
||||||
|
math-internals namespaces sequences ;
|
||||||
|
|
||||||
M: %type generate-node ( vop -- )
|
\ tag [
|
||||||
|
"in" operand tag-mask AND
|
||||||
|
"in" operand tag-bits SHL
|
||||||
|
] H{
|
||||||
|
{ +input { { f "in" } } }
|
||||||
|
{ +output { "in" } }
|
||||||
|
} define-intrinsic
|
||||||
|
|
||||||
|
\ type [
|
||||||
#! Intrinstic version of type primitive.
|
#! Intrinstic version of type primitive.
|
||||||
drop
|
|
||||||
<label> "header" set
|
<label> "header" set
|
||||||
<label> "f" set
|
<label> "f" set
|
||||||
<label> "end" set
|
<label> "end" set
|
||||||
! Make a copy
|
! Make a copy
|
||||||
0 scratch 0 output-operand MOV
|
"x" operand "obj" operand MOV
|
||||||
! Get the tag
|
! Get the tag
|
||||||
0 output-operand tag-mask AND
|
"obj" operand tag-mask AND
|
||||||
! Compare with object tag number (3).
|
! Compare with object tag number (3).
|
||||||
0 output-operand object-tag CMP
|
"obj" operand object-tag CMP
|
||||||
! Jump if the object doesn't store type info in its header
|
! Jump if the object doesn't store type info in its header
|
||||||
"header" get JE
|
"header" get JE
|
||||||
! It doesn't store type info in its header
|
! It doesn't store type info in its header
|
||||||
0 output-operand tag-bits SHL
|
"obj" operand tag-bits SHL
|
||||||
"end" get JMP
|
"end" get JMP
|
||||||
"header" get save-xt
|
"header" get save-xt
|
||||||
! It does store type info in its header
|
! It does store type info in its header
|
||||||
! Is the pointer itself equal to 3? Then its F_TYPE (9).
|
! Is the pointer itself equal to 3? Then its F_TYPE (9).
|
||||||
0 scratch object-tag CMP
|
"x" operand object-tag CMP
|
||||||
"f" get JE
|
"f" get JE
|
||||||
! The pointer is not equal to 3. Load the object header.
|
! The pointer is not equal to 3. Load the object header.
|
||||||
0 output-operand 0 scratch object-tag neg [+] MOV
|
"obj" operand "x" operand object-tag neg [+] MOV
|
||||||
! Mask off header tag, making a fixnum.
|
! Mask off header tag, making a fixnum.
|
||||||
0 output-operand object-tag XOR
|
"obj" operand object-tag XOR
|
||||||
"end" get JMP
|
"end" get JMP
|
||||||
"f" get save-xt
|
"f" get save-xt
|
||||||
! The pointer is equal to 3. Load F_TYPE (9).
|
! The pointer is equal to 3. Load F_TYPE (9).
|
||||||
0 output-operand f type tag-bits shift MOV
|
"obj" operand f type tag-bits shift MOV
|
||||||
"end" get save-xt ;
|
"end" get save-xt
|
||||||
|
] H{
|
||||||
|
{ +input { { f "obj" } } }
|
||||||
|
{ +scratch { { f "x" } { f "y" } } }
|
||||||
|
{ +output { "obj" } }
|
||||||
|
} define-intrinsic
|
||||||
|
|
||||||
M: %tag generate-node ( vop -- )
|
: untag ( reg -- ) tag-mask bitnot AND ;
|
||||||
drop
|
|
||||||
0 input-operand tag-mask AND
|
|
||||||
0 input-operand tag-bits SHL ;
|
|
||||||
|
|
||||||
M: %untag generate-node ( vop -- )
|
\ slot [
|
||||||
drop
|
"obj" operand untag
|
||||||
0 output-operand tag-mask bitnot AND ;
|
|
||||||
|
|
||||||
M: %slot generate-node ( vop -- )
|
|
||||||
drop
|
|
||||||
! turn tagged fixnum slot # into an offset, multiple of 4
|
! turn tagged fixnum slot # into an offset, multiple of 4
|
||||||
0 input-operand fixnum>slot@
|
"n" operand fixnum>slot@
|
||||||
! compute slot address
|
! compute slot address
|
||||||
dest/src ADD
|
"obj" operand "n" operand ADD
|
||||||
! load slot value
|
! load slot value
|
||||||
0 output-operand dup [] MOV ;
|
"obj" operand dup [] MOV
|
||||||
|
] H{
|
||||||
|
{ +input { { f "obj" } { f "n" } } }
|
||||||
|
{ +output { "obj" } }
|
||||||
|
{ +clobber { "n" } }
|
||||||
|
} define-intrinsic
|
||||||
|
|
||||||
: card-offset 1 getenv ; inline
|
: card-offset 1 getenv ; inline
|
||||||
|
|
||||||
M: %write-barrier generate-node ( vop -- )
|
: generate-write-barrier ( -- )
|
||||||
#! Mark the card pointed to by vreg.
|
#! Mark the card pointed to by vreg.
|
||||||
drop
|
"obj" operand card-bits SHR
|
||||||
0 input-operand card-bits SHR
|
"obj" operand card-offset ADD rel-absolute-cell rel-cards
|
||||||
0 input-operand card-offset ADD rel-absolute-cell rel-cards
|
"obj" operand [] card-mark OR ;
|
||||||
0 input-operand [] card-mark OR ;
|
|
||||||
|
|
||||||
M: %set-slot generate-node ( vop -- )
|
\ set-slot [
|
||||||
drop
|
"obj" operand untag
|
||||||
! turn tagged fixnum slot # into an offset
|
! turn tagged fixnum slot # into an offset
|
||||||
2 input-operand fixnum>slot@
|
"slot" operand fixnum>slot@
|
||||||
! compute slot address
|
! compute slot address
|
||||||
2 input-operand 1 input-operand ADD
|
"obj" operand "slot" operand ADD
|
||||||
! store new slot value
|
! store new slot value
|
||||||
2 input-operand [] 0 input-operand MOV ;
|
"obj" operand [] "val" operand MOV
|
||||||
|
generate-write-barrier
|
||||||
|
] H{
|
||||||
|
{ +input { { f "val" } { f "obj" } { f "slot" } } }
|
||||||
|
{ +scratch { { f "x" } } }
|
||||||
|
{ +clobber { "obj" } }
|
||||||
|
} define-intrinsic
|
||||||
|
|
||||||
: >register-16 ( reg -- reg )
|
\ char-slot [
|
||||||
"register" word-prop { AX CX DX } nth ;
|
EBX PUSH
|
||||||
|
"n" operand 2 SHR
|
||||||
|
EBX dup XOR
|
||||||
|
EBX "n" operand ADD
|
||||||
|
BX "obj" operand string-offset [+] MOV
|
||||||
|
EBX tag-bits SHL
|
||||||
|
"obj" operand EBX MOV
|
||||||
|
EBX POP
|
||||||
|
] H{
|
||||||
|
{ +input { { f "n" } { f "obj" } } }
|
||||||
|
{ +output { "obj" } }
|
||||||
|
{ +clobber { "n" } }
|
||||||
|
} define-intrinsic
|
||||||
|
|
||||||
: scratch-16 ( n -- reg ) scratch >register-16 ;
|
\ set-char-slot [
|
||||||
|
"obj" operand untag
|
||||||
|
EBX PUSH
|
||||||
|
"val" operand tag-bits SHR
|
||||||
|
"slot" operand 2 SHR
|
||||||
|
"obj" operand "slot" operand ADD
|
||||||
|
EBX "val" operand MOV
|
||||||
|
"obj" operand string-offset [+] BX MOV
|
||||||
|
EBX POP
|
||||||
|
] H{
|
||||||
|
{ +input { { f "val" } { f "slot" } { f "obj" } } }
|
||||||
|
{ +clobber { "obj" } }
|
||||||
|
} define-intrinsic
|
||||||
|
|
||||||
M: %char-slot generate-node ( vop -- )
|
: define-binary-op ( word op -- )
|
||||||
drop
|
[ [ "x" operand "y" operand ] % , ] [ ] make H{
|
||||||
0 input-operand 2 SHR
|
{ +input { { f "x" } { f "y" } } }
|
||||||
0 scratch dup XOR
|
{ +output { "x" } }
|
||||||
dest/src ADD
|
} define-intrinsic ;
|
||||||
0 scratch-16 0 output-operand string-offset [+] MOV
|
|
||||||
0 scratch tag-bits SHL
|
|
||||||
0 output-operand 0 scratch MOV ;
|
|
||||||
|
|
||||||
M: %set-char-slot generate-node ( vop -- )
|
{
|
||||||
drop
|
{ fixnum+fast ADD }
|
||||||
0 input-operand tag-bits SHR
|
{ fixnum-fast SUB }
|
||||||
2 input-operand 2 SHR
|
{ fixnum-bitand AND }
|
||||||
2 input-operand 1 input-operand ADD
|
{ fixnum-bitor OR }
|
||||||
2 input-operand string-offset [+]
|
{ fixnum-bitxor XOR }
|
||||||
0 input-operand >register-16 MOV ;
|
} [
|
||||||
|
first2 define-binary-op
|
||||||
|
] each
|
||||||
|
|
||||||
: literal-overflow ( -- dest src )
|
\ fixnum-bitnot [
|
||||||
#! Called if the src operand is a literal.
|
"x" operand NOT
|
||||||
#! Untag the dest operand.
|
"x" operand tag-mask XOR
|
||||||
dest/src over tag-bits SAR tag-bits neg shift ;
|
] H{
|
||||||
|
{ +input { { f "x" } } }
|
||||||
|
{ +output { "x" } }
|
||||||
|
} define-intrinsic
|
||||||
|
|
||||||
: computed-overflow ( -- dest src )
|
! This has specific register requirements. Inputs are in
|
||||||
#! Called if the src operand is a register.
|
! ECX and EAX, and the result is in EDX.
|
||||||
#! Untag both operands.
|
\ fixnum-mod [
|
||||||
dest/src 2dup tag-bits SAR tag-bits SAR ;
|
|
||||||
|
|
||||||
: simple-overflow ( inverse word -- )
|
|
||||||
#! If the previous arithmetic operation overflowed, then we
|
|
||||||
#! turn the result into a bignum and leave it in EAX.
|
|
||||||
<label> "end" set
|
|
||||||
"end" get JNO
|
|
||||||
! There was an overflow. Recompute the original operand.
|
|
||||||
>r >r dest/src r> execute
|
|
||||||
0 input integer? [ literal-overflow ] [ computed-overflow ] if
|
|
||||||
! Compute a result, this time it will fit.
|
|
||||||
r> execute
|
|
||||||
! Create a bignum.
|
|
||||||
"s48_long_to_bignum" f 0 output-operand
|
|
||||||
1array compile-c-call*
|
|
||||||
! An untagged pointer to the bignum is now in EAX; tag it
|
|
||||||
T{ int-regs } return-reg bignum-tag OR
|
|
||||||
"end" get save-xt ; inline
|
|
||||||
|
|
||||||
M: %fixnum+ generate-node ( vop -- )
|
|
||||||
drop dest/src ADD \ SUB \ ADD simple-overflow ;
|
|
||||||
|
|
||||||
M: %fixnum+fast generate-node ( vop -- ) drop dest/src ADD ;
|
|
||||||
|
|
||||||
M: %fixnum- generate-node ( vop -- )
|
|
||||||
drop dest/src SUB \ ADD \ SUB simple-overflow ;
|
|
||||||
|
|
||||||
M: %fixnum-fast generate-node ( vop -- ) drop dest/src SUB ;
|
|
||||||
|
|
||||||
M: %fixnum* generate-node ( vop -- )
|
|
||||||
drop
|
|
||||||
! both inputs are tagged, so one of them needs to have its
|
|
||||||
! tag removed.
|
|
||||||
1 input-operand tag-bits SAR
|
|
||||||
0 input-operand IMUL
|
|
||||||
<label> "end" set
|
|
||||||
"end" get JNO
|
|
||||||
"s48_fixnum_pair_to_bignum" f
|
|
||||||
1 input-operand remainder-reg 2array compile-c-call*
|
|
||||||
! now we have to shift it by three bits to remove the second
|
|
||||||
! tag
|
|
||||||
"s48_bignum_arithmetic_shift" f
|
|
||||||
1 input-operand tag-bits neg 2array compile-c-call*
|
|
||||||
! an untagged pointer to the bignum is now in EAX; tag it
|
|
||||||
T{ int-regs } return-reg bignum-tag OR
|
|
||||||
"end" get save-xt ;
|
|
||||||
|
|
||||||
M: %fixnum-mod generate-node ( vop -- )
|
|
||||||
#! This has specific register requirements. Inputs are in
|
|
||||||
#! ECX and EAX, and the result is in EDX.
|
|
||||||
drop
|
|
||||||
prepare-division
|
prepare-division
|
||||||
0 input-operand IDIV ;
|
"x" operand IDIV
|
||||||
|
] H{
|
||||||
|
{ +input { { 0 "x" } { 2 "y" } } }
|
||||||
|
{ +output { "x" } }
|
||||||
|
} define-intrinsic
|
||||||
|
|
||||||
: generate-fixnum/mod
|
! : literal-overflow ( -- dest src )
|
||||||
#! The same code is used for %fixnum/i and %fixnum/mod.
|
! #! Called if the src operand is a literal.
|
||||||
#! This has specific register requirements. Inputs are in
|
! #! Untag the dest operand.
|
||||||
#! ECX and EAX, and the result is in EDX.
|
! dest/src over tag-bits SAR tag-bits neg shift ;
|
||||||
<label> "end" set
|
!
|
||||||
prepare-division
|
! : computed-overflow ( -- dest src )
|
||||||
0 input-operand IDIV
|
! #! Called if the src operand is a register.
|
||||||
! Make a copy since following shift is destructive
|
! #! Untag both operands.
|
||||||
0 input-operand 1 input-operand MOV
|
! dest/src 2dup tag-bits SAR tag-bits SAR ;
|
||||||
! Tag the value, since division cancelled tags from both
|
!
|
||||||
! inputs
|
! : simple-overflow ( inverse word -- )
|
||||||
1 input-operand tag-bits SHL
|
! #! If the previous arithmetic operation overflowed, then we
|
||||||
! Did it overflow?
|
! #! turn the result into a bignum and leave it in EAX.
|
||||||
"end" get JNO
|
! <label> "end" set
|
||||||
! There was an overflow, so make ECX into a bignum. we must
|
! "end" get JNO
|
||||||
! save EDX since its volatile.
|
! ! There was an overflow. Recompute the original operand.
|
||||||
remainder-reg PUSH
|
! >r >r dest/src r> execute
|
||||||
"s48_long_to_bignum" f
|
! 0 input integer? [ literal-overflow ] [ computed-overflow ] if
|
||||||
0 input-operand 1array compile-c-call*
|
! ! Compute a result, this time it will fit.
|
||||||
! An untagged pointer to the bignum is now in EAX; tag it
|
! r> execute
|
||||||
T{ int-regs } return-reg bignum-tag OR
|
! ! Create a bignum.
|
||||||
! the remainder is now in EDX
|
! "s48_long_to_bignum" f 0 output-operand
|
||||||
remainder-reg POP
|
! 1array compile-c-call*
|
||||||
"end" get save-xt ;
|
! ! An untagged pointer to the bignum is now in EAX; tag it
|
||||||
|
! T{ int-regs } return-reg bignum-tag OR
|
||||||
|
! "end" get save-xt ; inline
|
||||||
|
!
|
||||||
|
! M: %fixnum+ generate-node ( vop -- )
|
||||||
|
! drop dest/src ADD \ SUB \ ADD simple-overflow ;
|
||||||
|
!
|
||||||
|
! M: %fixnum- generate-node ( vop -- )
|
||||||
|
! drop dest/src SUB \ ADD \ SUB simple-overflow ;
|
||||||
|
!
|
||||||
|
! M: %fixnum* generate-node ( vop -- )
|
||||||
|
! drop
|
||||||
|
! ! both inputs are tagged, so one of them needs to have its
|
||||||
|
! ! tag removed.
|
||||||
|
! 1 input-operand tag-bits SAR
|
||||||
|
! 0 input-operand IMUL
|
||||||
|
! <label> "end" set
|
||||||
|
! "end" get JNO
|
||||||
|
! "s48_fixnum_pair_to_bignum" f
|
||||||
|
! 1 input-operand remainder-reg 2array compile-c-call*
|
||||||
|
! ! now we have to shift it by three bits to remove the second
|
||||||
|
! ! tag
|
||||||
|
! "s48_bignum_arithmetic_shift" f
|
||||||
|
! 1 input-operand tag-bits neg 2array compile-c-call*
|
||||||
|
! ! an untagged pointer to the bignum is now in EAX; tag it
|
||||||
|
! T{ int-regs } return-reg bignum-tag OR
|
||||||
|
! "end" get save-xt ;
|
||||||
|
!
|
||||||
|
! : generate-fixnum/mod
|
||||||
|
! #! The same code is used for %fixnum/i and %fixnum/mod.
|
||||||
|
! #! This has specific register requirements. Inputs are in
|
||||||
|
! #! ECX and EAX, and the result is in EDX.
|
||||||
|
! <label> "end" set
|
||||||
|
! prepare-division
|
||||||
|
! 0 input-operand IDIV
|
||||||
|
! ! Make a copy since following shift is destructive
|
||||||
|
! 0 input-operand 1 input-operand MOV
|
||||||
|
! ! Tag the value, since division cancelled tags from both
|
||||||
|
! ! inputs
|
||||||
|
! 1 input-operand tag-bits SHL
|
||||||
|
! ! Did it overflow?
|
||||||
|
! "end" get JNO
|
||||||
|
! ! There was an overflow, so make ECX into a bignum. we must
|
||||||
|
! ! save EDX since its volatile.
|
||||||
|
! remainder-reg PUSH
|
||||||
|
! "s48_long_to_bignum" f
|
||||||
|
! 0 input-operand 1array compile-c-call*
|
||||||
|
! ! An untagged pointer to the bignum is now in EAX; tag it
|
||||||
|
! T{ int-regs } return-reg bignum-tag OR
|
||||||
|
! ! the remainder is now in EDX
|
||||||
|
! remainder-reg POP
|
||||||
|
! "end" get save-xt ;
|
||||||
|
!
|
||||||
|
! M: %fixnum/i generate-node drop generate-fixnum/mod ;
|
||||||
|
!
|
||||||
|
! M: %fixnum/mod generate-node drop generate-fixnum/mod ;
|
||||||
|
|
||||||
M: %fixnum/i generate-node drop generate-fixnum/mod ;
|
: define-binary-jump ( word op -- )
|
||||||
|
[
|
||||||
|
[ end-basic-block "x" operand "y" operand CMP ] % ,
|
||||||
|
] [ ] make H{
|
||||||
|
{ +input { { f "x" } { f "y" } } }
|
||||||
|
} define-if-intrinsic ;
|
||||||
|
|
||||||
M: %fixnum/mod generate-node drop generate-fixnum/mod ;
|
{
|
||||||
|
{ fixnum< JL }
|
||||||
|
{ fixnum<= JLE }
|
||||||
|
{ fixnum> JG }
|
||||||
|
{ fixnum>= JGE }
|
||||||
|
{ eq? JE }
|
||||||
|
} [
|
||||||
|
first2 define-binary-jump
|
||||||
|
] each
|
||||||
|
|
||||||
M: %fixnum-bitand generate-node ( vop -- ) drop dest/src AND ;
|
: %userenv ( -- )
|
||||||
|
"x" operand "userenv" f dlsym MOV
|
||||||
|
rel-absolute-cell rel-userenv
|
||||||
|
"n" operand 1 SHR
|
||||||
|
"n" operand "x" operand ADD ;
|
||||||
|
|
||||||
M: %fixnum-bitor generate-node ( vop -- ) drop dest/src OR ;
|
\ getenv [
|
||||||
|
%userenv "n" operand dup [] MOV
|
||||||
|
] H{
|
||||||
|
{ +input { { f "n" } } }
|
||||||
|
{ +scratch { { f "x" } } }
|
||||||
|
{ +output { "n" } }
|
||||||
|
} define-intrinsic
|
||||||
|
|
||||||
M: %fixnum-bitxor generate-node ( vop -- ) drop dest/src XOR ;
|
\ setenv [
|
||||||
|
%userenv "n" operand [] "val" operand MOV
|
||||||
M: %fixnum-bitnot generate-node ( vop -- )
|
] H{
|
||||||
drop
|
{ +input { { f "val" } { f "n" } } }
|
||||||
! Negate the bits of the operand
|
{ +scratch { { f "x" } } }
|
||||||
0 output-operand NOT
|
{ +clobber { "n" } }
|
||||||
! Mask off the low 3 bits to give a fixnum tag
|
} define-intrinsic
|
||||||
0 output-operand tag-mask XOR ;
|
|
||||||
|
|
||||||
M: %fixnum>> generate-node
|
|
||||||
drop
|
|
||||||
! shift register
|
|
||||||
0 output-operand 0 input SAR
|
|
||||||
! give it a fixnum tag
|
|
||||||
0 output-operand tag-mask bitnot AND ;
|
|
||||||
|
|
||||||
M: %fixnum-sgn generate-node
|
|
||||||
#! This has specific register requirements.
|
|
||||||
drop
|
|
||||||
! store 0 in EDX if EAX is >=0, otherwise store -1.
|
|
||||||
prepare-division
|
|
||||||
! give it a fixnum tag.
|
|
||||||
0 output-operand tag-bits SHL ;
|
|
||||||
|
|
||||||
: fixnum-jump ( -- label )
|
|
||||||
1 input-operand 0 input-operand CMP label ;
|
|
||||||
|
|
||||||
M: %jump-fixnum< generate-node ( vop -- ) drop fixnum-jump JL ;
|
|
||||||
M: %jump-fixnum<= generate-node ( vop -- ) drop fixnum-jump JLE ;
|
|
||||||
M: %jump-fixnum> generate-node ( vop -- ) drop fixnum-jump JG ;
|
|
||||||
M: %jump-fixnum>= generate-node ( vop -- ) drop fixnum-jump JGE ;
|
|
||||||
M: %jump-eq? generate-node ( vop -- ) drop fixnum-jump JE ;
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue