steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Slava Pestov 2008-11-28 22:26:49 -06:00
parent bac609d7af 2fc87a047a
commit 9081247e34
3 changed files with 77 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

102
basis/cpu/ppc/ppc.factor
View File

@ -38,6 +38,9 @@ M: ppc %load-immediate ( reg n -- ) swap LOAD ;
M: ppc %load-indirect ( reg obj -- ) M: ppc %load-indirect ( reg obj -- )
[ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ; [ 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 : ds-reg 29 ; inline
: rs-reg 30 ; inline : rs-reg 30 ; inline
@ -166,10 +169,14 @@ M: ppc %sar-imm SRAWI ;
M: ppc %not NOT ; M: ppc %not NOT ;
: %alien-invoke-tail ( func dll -- ) : %alien-invoke-tail ( func dll -- )
11 %load-dlsym 11 MTCTR BCTR ; scratch-reg %load-dlsym scratch-reg MTCTR BCTR ;
: exchange-regs ( r1 r2 -- ) :: exchange-regs ( r1 r2 -- )
scratch-reg swap MR scratch-reg MR ; scratch-reg r1 MR
r1 r2 MR
r2 scratch-reg MR ;
: ?MR ( r1 r2 -- ) 2dup = [ 2drop ] [ MR ] if ;
:: move>args ( src1 src2 -- ) :: move>args ( src1 src2 -- )
{ {
@ -180,47 +187,71 @@ M: ppc %not NOT ;
[ 3 src1 MR 4 src2 MR ] [ 3 src1 MR 4 src2 MR ]
} cond ; } cond ;
:: overflow-check ( src1 src2 insn insn-o func -- ) :: overflow-template ( src1 src2 insn func -- )
"no-overflow" define-label "no-overflow" define-label
0 0 LI 0 0 LI
0 MTXER 0 MTXER
scratch-reg src1 src2 insn-o execute scratch-reg src2 src1 insn call
scratch-reg ds-reg 0 STW scratch-reg ds-reg 0 STW
"no-overflow" get BNO "no-overflow" get BNO
move>args src2 src1 move>args
%prepare-alien-invoke %prepare-alien-invoke
func f %alien-invoke func f %alien-invoke
"no-overflow" resolve-label ; inline "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 "no-overflow" define-label
0 0 LI 0 0 LI
0 MTXER 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 "no-overflow" get BNO
move>args src2 src2 tag-bits get SRAWI
src1 src2 move>args
%prepare-alien-invoke %prepare-alien-invoke
func f %alien-invoke-tail "overflow_fixnum_multiply" f %alien-invoke
"no-overflow" resolve-label "no-overflow" resolve-label ;
scratch-reg ds-reg 0 STW ; inline
M: ppc %fixnum-add ( src1 src2 -- ) M:: ppc %fixnum-mul-tail ( src1 src2 -- )
[ ADD ] [ ADDO. ] "overflow_fixnum_add" overflow-template ; "overflow" define-label
0 0 LI
M: ppc %fixnum-add-tail ( src1 src2 -- ) 0 MTXER
[ ADD ] [ ADDO. ] "overflow_fixnum_add" overflow-template-tail ; src1 src1 tag-bits get SRAWI
scratch-reg src1 src2 MULLWO.
M: ppc %fixnum-sub ( src1 src2 -- ) "overflow" get BO
[ SUBF ] [ SUBFO. ] "overflow_fixnum_subtract" overflow-template ; scratch-reg ds-reg 0 STW
BLR
M: ppc %fixnum-sub-tail ( src1 src2 -- ) "overflow" resolve-label
[ SUBF ] [ SUBFO. ] "overflow_fixnum_subtract" overflow-template-tail ; src2 src2 tag-bits get SRAWI
src1 src2 move>args
M: ppc %fixnum-mul ( src1 src2 -- ) %prepare-alien-invoke
[ MULLW ] [ MULLWO. ] "overflow_fixnum_multiply" overflow-template ; "overflow_fixnum_multiply" f %alien-invoke-tail ;
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
@ -376,9 +407,6 @@ M: ppc %set-alien-cell swap 0 STW ;
M: ppc %set-alien-float swap 0 STFS ; M: ppc %set-alien-float swap 0 STFS ;
M: ppc %set-alien-double swap 0 STFD ; 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 -- ) : load-zone-ptr ( reg -- )
[ "nursery" f ] dip %load-dlsym ; [ "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 #! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace #! callback which does a GC, which must reliably trace
#! all roots. #! all roots.
"stack_chain" f 11 %load-dlsym "stack_chain" f scratch-reg %load-dlsym
11 11 0 LWZ scratch-reg scratch-reg 0 LWZ
1 11 0 STW 1 scratch-reg 0 STW
ds-reg 11 8 STW ds-reg scratch-reg 8 STW
rs-reg 11 12 STW ; rs-reg scratch-reg 12 STW ;
M: ppc %alien-invoke ( symbol dll -- ) M: ppc %alien-invoke ( symbol dll -- )
11 %load-dlsym 11 MTLR BLRL ; 11 %load-dlsym 11 MTLR BLRL ;

6
basis/ui/windows/windows.factor
View File

@ -285,7 +285,7 @@ SYMBOL: nc-buttons
swap [ push ] [ delete ] if ; swap [ push ] [ delete ] if ;
: >lo-hi ( WORD -- array ) [ lo-word ] keep hi-word 2array ; : >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 ) : mouse-absolute>relative ( lparam handle -- array )
[ >lo-hi ] dip [ >lo-hi ] dip
@ -338,8 +338,8 @@ SYMBOL: nc-buttons
>lo-hi swap window move-hand fire-motion ; >lo-hi swap window move-hand fire-motion ;
:: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- ) :: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
lParam mouse-wheel wParam mouse-wheel
hWnd mouse-absolute>relative lParam hWnd mouse-absolute>relative
hWnd window send-wheel ; hWnd window send-wheel ;
: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- ) : handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )

14
vm/cpu-ppc.S
View File

@ -2,7 +2,7 @@
in the public domain. */ in the public domain. */
#include "asm.h" #include "asm.h"
#define DS_REG 29 #define DS_REG r29
DEF(void,primitive_fixnum_add,(void)): DEF(void,primitive_fixnum_add,(void)):
lwz r3,0(DS_REG) lwz r3,0(DS_REG)
@ -11,9 +11,11 @@ DEF(void,primitive_fixnum_add,(void)):
li r0,0 li r0,0
mtxer r0 mtxer r0
addo. r5,r3,r4 addo. r5,r3,r4
bo MANGLE(overflow_fixnum_add) bso add_overflow
stw r5,0(DS_REG) stw r5,0(DS_REG)
blr blr
add_overflow:
b MANGLE(overflow_fixnum_add)
DEF(void,primitive_fixnum_subtract,(void)): DEF(void,primitive_fixnum_subtract,(void)):
lwz r3,0(DS_REG) lwz r3,0(DS_REG)
@ -22,9 +24,11 @@ DEF(void,primitive_fixnum_subtract,(void)):
li r0,0 li r0,0
mtxer r0 mtxer r0
subfo. r5,r3,r4 subfo. r5,r3,r4
bo MANGLE(overflow_fixnum_subtract) bso sub_overflow
stw r5,0(DS_REG) stw r5,0(DS_REG)
blr blr
sub_overflow:
b MANGLE(overflow_fixnum_subtract)
DEF(void,primitive_fixnum_multiply,(void)): DEF(void,primitive_fixnum_multiply,(void)):
lwz r3,0(DS_REG) lwz r3,0(DS_REG)
@ -32,12 +36,12 @@ DEF(void,primitive_fixnum_multiply,(void)):
subi DS_REG,DS_REG,4 subi DS_REG,DS_REG,4
srawi r3,r3,3 srawi r3,r3,3
mullwo. r5,r3,r4 mullwo. r5,r3,r4
bo multiply_overflow bso multiply_overflow
stw r5,0(DS_REG) stw r5,0(DS_REG)
blr blr
multiply_overflow: multiply_overflow:
srawi r4,r4,3 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 */ /* Note that the XT is passed to the quotation in r11 */
#define CALL_OR_JUMP_QUOT \ #define CALL_OR_JUMP_QUOT \