Merge branch 'master' of git://factorcode.org/git/factor into faster_overflow_checks

db4
Slava Pestov 2008-11-28 22:26:49 -06:00
commit 9081247e34
3 changed files with 77 additions and 45 deletions

View File

@ -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 ;

View File

@ -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 -- )

View File

@ -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 \