130 lines
4.2 KiB
Factor
130 lines
4.2 KiB
Factor
! Copyright (C) 2005 Slava Pestov.
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
IN: compiler-backend
|
|
USING: assembler compiler kernel kernel-internals math
|
|
math-internals memory namespaces words ;
|
|
|
|
: >3-vop< ( -- out1 in1 in2 )
|
|
0 output-operand 0 input-operand 1 input-operand ;
|
|
|
|
: simple-overflow ( inv word -- )
|
|
>r >r
|
|
<label> "end" set
|
|
"end" get BNO
|
|
>3-vop< r> execute
|
|
0 input-operand dup untag-fixnum
|
|
1 input-operand dup untag-fixnum
|
|
>3-vop< r> execute
|
|
"s48_long_to_bignum" f compile-c-call
|
|
! An untagged pointer to the bignum is now in r3; tag it
|
|
0 output-operand dup bignum-tag ORI
|
|
"end" get save-xt ; inline
|
|
|
|
M: %fixnum+ generate-node ( vop -- )
|
|
drop 0 MTXER >3-vop< ADDO. \ SUBF \ ADD simple-overflow ;
|
|
|
|
M: %fixnum- generate-node ( vop -- )
|
|
drop 0 MTXER >3-vop< SUBFO. \ ADD \ SUBF simple-overflow ;
|
|
|
|
M: %fixnum* generate-node ( vop -- )
|
|
#! Note that this assumes the output will be in r3.
|
|
drop
|
|
<label> "end" set
|
|
1 input-operand dup untag-fixnum
|
|
0 MTXER
|
|
0 scratch 0 input-operand 1 input-operand MULLWO.
|
|
"end" get BNO
|
|
1 scratch 0 input-operand 1 input-operand MULHW
|
|
4 1 scratch MR
|
|
3 0 scratch MR
|
|
"s48_fixnum_pair_to_bignum" f compile-c-call
|
|
! now we have to shift it by three bits to remove the second
|
|
! tag
|
|
tag-bits neg 4 LI
|
|
"s48_bignum_arithmetic_shift" f compile-c-call
|
|
! An untagged pointer to the bignum is now in r3; tag it
|
|
0 output-operand 0 scratch bignum-tag ORI
|
|
"end" get save-xt
|
|
0 output-operand 0 scratch MR ;
|
|
|
|
: generate-fixnum/i
|
|
#! This VOP is funny. If there is an overflow, it falls
|
|
#! through to the end, and the result is in 0 output-operand.
|
|
#! Otherwise it jumps to the "no-overflow" label and the
|
|
#! result is in 0 scratch.
|
|
0 scratch 1 input-operand 0 input-operand DIVW
|
|
! if the result is greater than the most positive fixnum,
|
|
! which can only ever happen if we do
|
|
! most-negative-fixnum -1 /i, then the result is a bignum.
|
|
<label> "end" set
|
|
<label> "no-overflow" set
|
|
most-positive-fixnum 1 scratch LOAD
|
|
0 scratch 0 1 scratch CMP
|
|
"no-overflow" get BLE
|
|
most-negative-fixnum neg 3 LOAD
|
|
"s48_long_to_bignum" f compile-c-call
|
|
3 dup bignum-tag ORI ;
|
|
|
|
M: %fixnum/i generate-node ( vop -- )
|
|
#! This has specific vreg requirements.
|
|
drop
|
|
generate-fixnum/i
|
|
"end" get B
|
|
"no-overflow" get save-xt
|
|
0 scratch 0 output-operand tag-fixnum
|
|
"end" get save-xt ;
|
|
|
|
: generate-fixnum-mod
|
|
#! PowerPC doesn't have a MOD instruction; so we compute
|
|
#! x-(x/y)*y. Puts the result in 1 scratch.
|
|
1 scratch 0 scratch 0 input-operand MULLW
|
|
1 scratch 1 scratch 1 input-operand SUBF ;
|
|
|
|
M: %fixnum-mod generate-node ( vop -- )
|
|
drop
|
|
! divide in2 by in1, store result in out1
|
|
0 scratch 1 input-operand 0 input-operand DIVW
|
|
generate-fixnum-mod
|
|
0 output-operand 1 scratch MR ;
|
|
|
|
M: %fixnum/mod generate-node ( vop -- )
|
|
#! This has specific vreg requirements. Note: if there's an
|
|
#! overflow, (most-negative-fixnum 1 /mod) the modulus is
|
|
#! always zero.
|
|
drop
|
|
generate-fixnum/i
|
|
0 0 output-operand LI
|
|
"end" get B
|
|
"no-overflow" get save-xt
|
|
generate-fixnum-mod
|
|
0 scratch 1 output-operand tag-fixnum
|
|
0 output-operand 1 scratch MR
|
|
"end" get save-xt ;
|
|
|
|
M: %fixnum-bitand generate-node ( vop -- ) drop >3-vop< AND ;
|
|
|
|
M: %fixnum-bitor generate-node ( vop -- ) drop >3-vop< OR ;
|
|
|
|
M: %fixnum-bitxor generate-node ( vop -- ) drop >3-vop< XOR ;
|
|
|
|
M: %fixnum-bitnot generate-node ( vop -- )
|
|
drop dest/src NOT
|
|
0 output-operand dup untag ;
|
|
|
|
M: %fixnum>> generate-node ( vop -- )
|
|
drop
|
|
1 input-operand 0 output-operand 0 input SRAWI
|
|
0 output-operand dup untag ;
|
|
|
|
M: %fixnum-sgn generate-node ( vop -- )
|
|
drop dest/src cell-bits 1- SRAWI 0 output-operand dup untag ;
|
|
|
|
: fixnum-jump ( -- label )
|
|
1 input-operand 0 0 input-operand CMP label ;
|
|
|
|
M: %jump-fixnum< generate-node ( vop -- ) drop fixnum-jump BLT ;
|
|
M: %jump-fixnum<= generate-node ( vop -- ) drop fixnum-jump BLE ;
|
|
M: %jump-fixnum> generate-node ( vop -- ) drop fixnum-jump BGT ;
|
|
M: %jump-fixnum>= generate-node ( vop -- ) drop fixnum-jump BGE ;
|
|
M: %jump-eq? generate-node ( vop -- ) drop fixnum-jump BEQ ;
|