Fixing PowerPC arithmetic primitives

diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index f886a8b45c07643f17c0240f63de4e1f5eb382b0..aa9126fef07bf76800c90cfbf56f8c6700956f23 100644 (file)
--- 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 -- )
-    "no-overflow" define-label
+:: overflow-template-tail ( src1 src2 insn func -- )
+    "overflow" define-label
     0 0 LI
     0 MTXER
-    scratch-reg src1 src2 insn-o execute
-    "no-overflow" get BNO
-    move>args
+    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
-    "no-overflow" resolve-label
-    scratch-reg ds-reg 0 STW ; inline
+    func f %alien-invoke-tail ;
 
 M: ppc %fixnum-add ( src1 src2 -- )
-    [ ADD ] [ ADDO. ] "overflow_fixnum_add" overflow-template ;
+    [ ADDO. ] "overflow_fixnum_add" overflow-template ;
 
 M: ppc %fixnum-add-tail ( src1 src2 -- )
-    [ ADD ] [ ADDO. ] "overflow_fixnum_add" overflow-template-tail ;
+    [ ADDO. ] "overflow_fixnum_add" overflow-template-tail ;
 
 M: ppc %fixnum-sub ( src1 src2 -- )
-    [ SUBF ] [ SUBFO. ] "overflow_fixnum_subtract" overflow-template ;
+    [ SUBFO. ] "overflow_fixnum_subtract" overflow-template ;
 
 M: ppc %fixnum-sub-tail ( src1 src2 -- )
-    [ SUBF ] [ SUBFO. ] "overflow_fixnum_subtract" overflow-template-tail ;
+    [ SUBFO. ] "overflow_fixnum_subtract" overflow-template-tail ;
 
-M: ppc %fixnum-mul ( src1 src2 -- )
-    [ MULLW ] [ MULLWO. ] "overflow_fixnum_multiply" overflow-template ;
+M:: ppc %fixnum-mul ( src1 src2 -- )
+    "no-overflow" define-label
+    0 0 LI
+    0 MTXER
+    src1 src1 tag-bits get SRAWI
+    scratch-reg src1 src2 MULLWO.
+    scratch-reg ds-reg 0 STW
+    "no-overflow" get BNO
+    src2 src2 tag-bits get SRAWI
+    src1 src2 move>args
+    %prepare-alien-invoke
+    "overflow_fixnum_multiply" f %alien-invoke
+    "no-overflow" resolve-label ;
 
-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/vm/cpu-ppc.S b/vm/cpu-ppc.S
index f7a11f9d12a0c548ef1a145f63c77be6b46377c2..17db7422110d60ddb4d320023b2abb7becfe5312 100755 (executable)
--- 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 \