Merge branch 'master' of git://factorcode.org/git/factor into faster_overflow_checks
Slava Pestov
commit
9081247e34
|
|
@ -38,6 +38,9 @@ M: ppc %load-immediate ( reg n -- ) swap LOAD ;
|
|||
M: ppc %load-indirect ( reg obj -- )
|
||||
[ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ;
|
||||
|
||||
: %load-dlsym ( symbol dll register -- )
|
||||
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
|
||||
|
||||
: ds-reg 29 ; inline
|
||||
: rs-reg 30 ; inline
|
||||
|
||||
|
|
@ -166,10 +169,14 @@ M: ppc %sar-imm SRAWI ;
|
|||
M: ppc %not NOT ;
|
||||
|
||||
: %alien-invoke-tail ( func dll -- )
|
||||
11 %load-dlsym 11 MTCTR BCTR ;
|
||||
scratch-reg %load-dlsym scratch-reg MTCTR BCTR ;
|
||||
|
||||
: exchange-regs ( r1 r2 -- )
|
||||
scratch-reg swap MR scratch-reg MR ;
|
||||
:: exchange-regs ( r1 r2 -- )
|
||||
scratch-reg r1 MR
|
||||
r1 r2 MR
|
||||
r2 scratch-reg MR ;
|
||||
|
||||
: ?MR ( r1 r2 -- ) 2dup = [ 2drop ] [ MR ] if ;
|
||||
|
||||
:: move>args ( src1 src2 -- )
|
||||
{
|
||||
|
|
@ -180,47 +187,71 @@ M: ppc %not NOT ;
|
|||
[ 3 src1 MR 4 src2 MR ]
|
||||
} cond ;
|
||||
|
||||
:: overflow-check ( src1 src2 insn insn-o func -- )
|
||||
:: overflow-template ( src1 src2 insn func -- )
|
||||
"no-overflow" define-label
|
||||
0 0 LI
|
||||
0 MTXER
|
||||
scratch-reg src1 src2 insn-o execute
|
||||
scratch-reg src2 src1 insn call
|
||||
scratch-reg ds-reg 0 STW
|
||||
"no-overflow" get BNO
|
||||
move>args
|
||||
src2 src1 move>args
|
||||
%prepare-alien-invoke
|
||||
func f %alien-invoke
|
||||
"no-overflow" resolve-label ; inline
|
||||
|
||||
:: overflow-check-tail ( src1 src2 insn insn-o func -- )
|
||||
:: overflow-template-tail ( src1 src2 insn func -- )
|
||||
"overflow" define-label
|
||||
0 0 LI
|
||||
0 MTXER
|
||||
scratch-reg src2 src1 insn call
|
||||
"overflow" get BO
|
||||
scratch-reg ds-reg 0 STW
|
||||
BLR
|
||||
"overflow" resolve-label
|
||||
src2 src1 move>args
|
||||
%prepare-alien-invoke
|
||||
func f %alien-invoke-tail ;
|
||||
|
||||
M: ppc %fixnum-add ( src1 src2 -- )
|
||||
[ ADDO. ] "overflow_fixnum_add" overflow-template ;
|
||||
|
||||
M: ppc %fixnum-add-tail ( src1 src2 -- )
|
||||
[ ADDO. ] "overflow_fixnum_add" overflow-template-tail ;
|
||||
|
||||
M: ppc %fixnum-sub ( src1 src2 -- )
|
||||
[ SUBFO. ] "overflow_fixnum_subtract" overflow-template ;
|
||||
|
||||
M: ppc %fixnum-sub-tail ( src1 src2 -- )
|
||||
[ SUBFO. ] "overflow_fixnum_subtract" overflow-template-tail ;
|
||||
|
||||
M:: ppc %fixnum-mul ( src1 src2 -- )
|
||||
"no-overflow" define-label
|
||||
0 0 LI
|
||||
0 MTXER
|
||||
scratch-reg src1 src2 insn-o execute
|
||||
src1 src1 tag-bits get SRAWI
|
||||
scratch-reg src1 src2 MULLWO.
|
||||
scratch-reg ds-reg 0 STW
|
||||
"no-overflow" get BNO
|
||||
move>args
|
||||
src2 src2 tag-bits get SRAWI
|
||||
src1 src2 move>args
|
||||
%prepare-alien-invoke
|
||||
func f %alien-invoke-tail
|
||||
"no-overflow" resolve-label
|
||||
scratch-reg ds-reg 0 STW ; inline
|
||||
"overflow_fixnum_multiply" f %alien-invoke
|
||||
"no-overflow" resolve-label ;
|
||||
|
||||
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 ;
|
||||
M:: ppc %fixnum-mul-tail ( src1 src2 -- )
|
||||
"overflow" define-label
|
||||
0 0 LI
|
||||
0 MTXER
|
||||
src1 src1 tag-bits get SRAWI
|
||||
scratch-reg src1 src2 MULLWO.
|
||||
"overflow" get BO
|
||||
scratch-reg ds-reg 0 STW
|
||||
BLR
|
||||
"overflow" resolve-label
|
||||
src2 src2 tag-bits get SRAWI
|
||||
src1 src2 move>args
|
||||
%prepare-alien-invoke
|
||||
"overflow_fixnum_multiply" f %alien-invoke-tail ;
|
||||
|
||||
: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
|
||||
|
||||
|
|
@ -376,9 +407,6 @@ M: ppc %set-alien-cell swap 0 STW ;
|
|||
M: ppc %set-alien-float swap 0 STFS ;
|
||||
M: ppc %set-alien-double swap 0 STFD ;
|
||||
|
||||
: %load-dlsym ( symbol dll register -- )
|
||||
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
|
||||
|
||||
: load-zone-ptr ( reg -- )
|
||||
[ "nursery" f ] dip %load-dlsym ;
|
||||
|
||||
|
|
@ -596,11 +624,11 @@ M: ppc %prepare-alien-invoke
|
|||
#! Save Factor stack pointers in case the C code calls a
|
||||
#! callback which does a GC, which must reliably trace
|
||||
#! all roots.
|
||||
"stack_chain" f 11 %load-dlsym
|
||||
11 11 0 LWZ
|
||||
1 11 0 STW
|
||||
ds-reg 11 8 STW
|
||||
rs-reg 11 12 STW ;
|
||||
"stack_chain" f scratch-reg %load-dlsym
|
||||
scratch-reg scratch-reg 0 LWZ
|
||||
1 scratch-reg 0 STW
|
||||
ds-reg scratch-reg 8 STW
|
||||
rs-reg scratch-reg 12 STW ;
|
||||
|
||||
M: ppc %alien-invoke ( symbol dll -- )
|
||||
11 %load-dlsym 11 MTLR BLRL ;
|
||||
|
|
|
|||
|
|
@ -285,7 +285,7 @@ SYMBOL: nc-buttons
|
|||
swap [ push ] [ delete ] if ;
|
||||
|
||||
: >lo-hi ( WORD -- array ) [ lo-word ] keep hi-word 2array ;
|
||||
: mouse-wheel ( lParam -- array ) >lo-hi [ sgn neg ] map ;
|
||||
: mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ;
|
||||
|
||||
: mouse-absolute>relative ( lparam handle -- array )
|
||||
[ >lo-hi ] dip
|
||||
|
|
@ -338,8 +338,8 @@ SYMBOL: nc-buttons
|
|||
>lo-hi swap window move-hand fire-motion ;
|
||||
|
||||
:: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
|
||||
lParam mouse-wheel
|
||||
hWnd mouse-absolute>relative
|
||||
wParam mouse-wheel
|
||||
lParam hWnd mouse-absolute>relative
|
||||
hWnd window send-wheel ;
|
||||
|
||||
: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
|
||||
|
|
|
|||
14
vm/cpu-ppc.S
14
vm/cpu-ppc.S
|
|
@ -2,7 +2,7 @@
|
|||
in the public domain. */
|
||||
#include "asm.h"
|
||||
|
||||
#define DS_REG 29
|
||||
#define DS_REG r29
|
||||
|
||||
DEF(void,primitive_fixnum_add,(void)):
|
||||
lwz r3,0(DS_REG)
|
||||
|
|
@ -11,9 +11,11 @@ DEF(void,primitive_fixnum_add,(void)):
|
|||
li r0,0
|
||||
mtxer r0
|
||||
addo. r5,r3,r4
|
||||
bo MANGLE(overflow_fixnum_add)
|
||||
bso add_overflow
|
||||
stw r5,0(DS_REG)
|
||||
blr
|
||||
add_overflow:
|
||||
b MANGLE(overflow_fixnum_add)
|
||||
|
||||
DEF(void,primitive_fixnum_subtract,(void)):
|
||||
lwz r3,0(DS_REG)
|
||||
|
|
@ -22,9 +24,11 @@ DEF(void,primitive_fixnum_subtract,(void)):
|
|||
li r0,0
|
||||
mtxer r0
|
||||
subfo. r5,r3,r4
|
||||
bo MANGLE(overflow_fixnum_subtract)
|
||||
bso sub_overflow
|
||||
stw r5,0(DS_REG)
|
||||
blr
|
||||
sub_overflow:
|
||||
b MANGLE(overflow_fixnum_subtract)
|
||||
|
||||
DEF(void,primitive_fixnum_multiply,(void)):
|
||||
lwz r3,0(DS_REG)
|
||||
|
|
@ -32,12 +36,12 @@ DEF(void,primitive_fixnum_multiply,(void)):
|
|||
subi DS_REG,DS_REG,4
|
||||
srawi r3,r3,3
|
||||
mullwo. r5,r3,r4
|
||||
bo multiply_overflow
|
||||
bso multiply_overflow
|
||||
stw r5,0(DS_REG)
|
||||
blr
|
||||
multiply_overflow:
|
||||
srawi r4,r4,3
|
||||
jmp MANGLE(overflow_fixnum_multiply)
|
||||
b MANGLE(overflow_fixnum_multiply)
|
||||
|
||||
/* Note that the XT is passed to the quotation in r11 */
|
||||
#define CALL_OR_JUMP_QUOT \
|
||||
|
|
|
|||
Loading…
Reference in New Issue