diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index f886a8b45c..aa9126fef0 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -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 ; diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 3805cf7e1f..6e1ce8f77f 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -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 -- ) diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index f7a11f9d12..17db742211 100755 --- a/vm/cpu-ppc.S +++ b/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 \