factor/library/compiler/x86/intrinsics.factor

222 lines
6.8 KiB
Factor

! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler
M: %type generate-node ( vop -- )
#! Intrinstic version of type primitive.
drop
<label> "header" set
<label> "f" set
<label> "end" set
! Make a copy
0 scratch 0 output-operand MOV
! Get the tag
0 output-operand tag-mask AND
! Compare with object tag number (3).
0 output-operand object-tag CMP
! Jump if the object doesn't store type info in its header
"header" get JE
! It doesn't store type info in its header
0 output-operand tag-bits SHL
"end" get JMP
"header" get save-xt
! It does store type info in its header
! Is the pointer itself equal to 3? Then its F_TYPE (9).
0 scratch object-tag CMP
"f" get JE
! The pointer is not equal to 3. Load the object header.
0 output-operand 0 scratch object-tag neg [+] MOV
! Mask off header tag, making a fixnum.
0 output-operand object-tag XOR
"end" get JMP
"f" get save-xt
! The pointer is equal to 3. Load F_TYPE (9).
0 output-operand f type tag-bits shift MOV
"end" get save-xt ;
M: %tag generate-node ( vop -- )
drop
0 input-operand tag-mask AND
0 input-operand tag-bits SHL ;
M: %untag generate-node ( vop -- )
drop
0 output-operand tag-mask bitnot AND ;
M: %slot generate-node ( vop -- )
drop
! turn tagged fixnum slot # into an offset, multiple of 4
0 input-operand fixnum>slot@
! compute slot address
dest/src ADD
! load slot value
0 output-operand dup [] MOV ;
: card-offset 1 getenv ; inline
M: %write-barrier generate-node ( vop -- )
#! Mark the card pointed to by vreg.
drop
0 input-operand card-bits SHR
0 input-operand card-offset ADD rel-absolute-cell rel-cards
0 input-operand [] card-mark OR ;
M: %set-slot generate-node ( vop -- )
drop
! turn tagged fixnum slot # into an offset
2 input-operand fixnum>slot@
! compute slot address
2 input-operand 1 input-operand ADD
! store new slot value
2 input-operand [] 0 input-operand MOV ;
: >register-16 ( reg -- reg )
"register" word-prop { AX CX DX } nth ;
: scratch-16 ( n -- reg ) scratch >register-16 ;
M: %char-slot generate-node ( vop -- )
drop
0 input-operand 2 SHR
0 scratch dup XOR
dest/src ADD
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
0 input-operand tag-bits SHR
2 input-operand 2 SHR
2 input-operand 1 input-operand ADD
2 input-operand string-offset [+]
0 input-operand >register-16 MOV ;
: literal-overflow ( -- dest src )
#! Called if the src operand is a literal.
#! Untag the dest operand.
dest/src over tag-bits SAR tag-bits neg shift ;
: computed-overflow ( -- dest src )
#! Called if the src operand is a register.
#! Untag both operands.
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
0 input-operand IDIV ;
: 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-bitand generate-node ( vop -- ) drop dest/src AND ;
M: %fixnum-bitor generate-node ( vop -- ) drop dest/src OR ;
M: %fixnum-bitxor generate-node ( vop -- ) drop dest/src XOR ;
M: %fixnum-bitnot generate-node ( vop -- )
drop
! Negate the bits of the operand
0 output-operand NOT
! Mask off the low 3 bits to give a fixnum tag
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 ;