Working on PowerPC overflow checks
Slava Pestov
parent
eb8c621b6f
commit
68dd6cc35a
|
|
@ -89,6 +89,9 @@ IN: compiler.cfg.intrinsics
|
||||||
alien.accessors:set-alien-double
|
alien.accessors:set-alien-double
|
||||||
} [ t "intrinsic" set-word-prop ] each ;
|
} [ t "intrinsic" set-word-prop ] each ;
|
||||||
|
|
||||||
|
: enable-fixnum*-intrinsic ( -- )
|
||||||
|
\ math.private:fixnum* t "intrinsic" set-word-prop ;
|
||||||
|
|
||||||
: emit-intrinsic ( node word -- node/f )
|
: emit-intrinsic ( node word -- node/f )
|
||||||
{
|
{
|
||||||
{ \ kernel.private:tag [ drop emit-tag iterate-next ] }
|
{ \ kernel.private:tag [ drop emit-tag iterate-next ] }
|
||||||
|
|
|
||||||
|
|
@ -17,6 +17,7 @@ IN: cpu.ppc
|
||||||
! f30, f31: float scratch
|
! f30, f31: float scratch
|
||||||
|
|
||||||
enable-float-intrinsics
|
enable-float-intrinsics
|
||||||
|
enable-fixnum*-intrinsic
|
||||||
|
|
||||||
<< \ ##integer>float t frame-required? set-word-prop
|
<< \ ##integer>float t frame-required? set-word-prop
|
||||||
\ ##float>integer t frame-required? set-word-prop >>
|
\ ##float>integer t frame-required? set-word-prop >>
|
||||||
|
|
@ -164,6 +165,63 @@ M: ppc %shr-imm swapd SRWI ;
|
||||||
M: ppc %sar-imm SRAWI ;
|
M: ppc %sar-imm SRAWI ;
|
||||||
M: ppc %not NOT ;
|
M: ppc %not NOT ;
|
||||||
|
|
||||||
|
: %alien-invoke-tail ( func dll -- )
|
||||||
|
11 %load-dlsym 11 MTCTR BCTR ;
|
||||||
|
|
||||||
|
: exchange-regs ( r1 r2 -- )
|
||||||
|
scratch-reg swap MR scratch-reg MR ;
|
||||||
|
|
||||||
|
:: move>args ( src1 src2 -- )
|
||||||
|
{
|
||||||
|
{ [ src1 4 = ] [ 3 src2 ?MR 3 4 exchange-regs ] }
|
||||||
|
{ [ src1 3 = ] [ 4 src2 ?MR ] }
|
||||||
|
{ [ src2 3 = ] [ 4 src1 ?MR 3 4 exchange-regs ] }
|
||||||
|
{ [ src2 4 = ] [ 3 src1 ?MR ] }
|
||||||
|
[ 3 src1 MR 4 src2 MR ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
:: overflow-check ( src1 src2 insn insn-o func -- )
|
||||||
|
"no-overflow" define-label
|
||||||
|
0 0 LI
|
||||||
|
0 MTXER
|
||||||
|
scratch-reg src1 src2 insn-o execute
|
||||||
|
scratch-reg ds-reg 0 STW
|
||||||
|
"no-overflow" get BNO
|
||||||
|
move>args
|
||||||
|
%prepare-alien-invoke
|
||||||
|
func f %alien-invoke
|
||||||
|
"no-overflow" resolve-label ; inline
|
||||||
|
|
||||||
|
:: overflow-check-tail ( src1 src2 insn insn-o func -- )
|
||||||
|
"no-overflow" define-label
|
||||||
|
0 0 LI
|
||||||
|
0 MTXER
|
||||||
|
scratch-reg src1 src2 insn-o execute
|
||||||
|
"no-overflow" get BNO
|
||||||
|
move>args
|
||||||
|
%prepare-alien-invoke
|
||||||
|
func f %alien-invoke-tail
|
||||||
|
"no-overflow" resolve-label
|
||||||
|
scratch-reg ds-reg 0 STW ; inline
|
||||||
|
|
||||||
|
M: ppc %fixnum-add ( src1 src2 -- )
|
||||||
|
[ ADD ] [ ADDO. ] "overflow_fixnum_add" overflow-template ;
|
||||||
|
|
||||||
|
M: ppc %fixnum-add-tail ( src1 src2 -- )
|
||||||
|
[ ADD ] [ ADDO. ] "overflow_fixnum_add" overflow-template-tail ;
|
||||||
|
|
||||||
|
M: ppc %fixnum-sub ( src1 src2 -- )
|
||||||
|
[ SUBF ] [ SUBFO. ] "overflow_fixnum_subtract" overflow-template ;
|
||||||
|
|
||||||
|
M: ppc %fixnum-sub-tail ( src1 src2 -- )
|
||||||
|
[ SUBF ] [ SUBFO. ] "overflow_fixnum_subtract" overflow-template-tail ;
|
||||||
|
|
||||||
|
M: ppc %fixnum-mul ( src1 src2 -- )
|
||||||
|
[ MULLW ] [ MULLWO. ] "overflow_fixnum_multiply" overflow-template ;
|
||||||
|
|
||||||
|
M: ppc %fixnum-mul-tail ( src1 src2 -- )
|
||||||
|
[ MULLW ] [ MULLWO. ] "overflow_fixnum_multiply" overflow-template-tail ;
|
||||||
|
|
||||||
: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
|
: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
|
||||||
|
|
||||||
M:: ppc %integer>bignum ( dst src temp -- )
|
M:: ppc %integer>bignum ( dst src temp -- )
|
||||||
|
|
|
||||||
37
vm/cpu-ppc.S
37
vm/cpu-ppc.S
|
|
@ -2,6 +2,43 @@
|
||||||
in the public domain. */
|
in the public domain. */
|
||||||
#include "asm.h"
|
#include "asm.h"
|
||||||
|
|
||||||
|
#define DS_REG 29
|
||||||
|
|
||||||
|
DEF(void,primitive_fixnum_add,(void)):
|
||||||
|
lwz r3,0(DS_REG)
|
||||||
|
lwz r4,-4(DS_REG)
|
||||||
|
subi DS_REG,DS_REG,4
|
||||||
|
li r0,0
|
||||||
|
mtxer r0
|
||||||
|
addo. r5,r3,r4
|
||||||
|
bo MANGLE(overflow_fixnum_add)
|
||||||
|
stw r5,0(DS_REG)
|
||||||
|
blr
|
||||||
|
|
||||||
|
DEF(void,primitive_fixnum_subtract,(void)):
|
||||||
|
lwz r3,0(DS_REG)
|
||||||
|
lwz r4,-4(DS_REG)
|
||||||
|
subi DS_REG,DS_REG,4
|
||||||
|
li r0,0
|
||||||
|
mtxer r0
|
||||||
|
subfo. r5,r3,r4
|
||||||
|
bo MANGLE(overflow_fixnum_subtract)
|
||||||
|
stw r5,0(DS_REG)
|
||||||
|
blr
|
||||||
|
|
||||||
|
DEF(void,primitive_fixnum_multiply,(void)):
|
||||||
|
lwz r3,0(DS_REG)
|
||||||
|
lwz r4,-4(DS_REG)
|
||||||
|
subi DS_REG,DS_REG,4
|
||||||
|
srawi r3,r3,3
|
||||||
|
mullwo. r5,r3,r4
|
||||||
|
bo multiply_overflow
|
||||||
|
stw r5,0(DS_REG)
|
||||||
|
blr
|
||||||
|
multiply_overflow:
|
||||||
|
srawi r4,r4,3
|
||||||
|
jmp MANGLE(overflow_fixnum_multiply)
|
||||||
|
|
||||||
/* Note that the XT is passed to the quotation in r11 */
|
/* Note that the XT is passed to the quotation in r11 */
|
||||||
#define CALL_OR_JUMP_QUOT \
|
#define CALL_OR_JUMP_QUOT \
|
||||||
lwz r11,9(r3) /* load quotation-xt slot */ XX \
|
lwz r11,9(r3) /* load quotation-xt slot */ XX \
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue