From 68dd6cc35a2ddec8160039222f4448c43513cad5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 28 Nov 2008 20:02:50 -0600
Subject: [PATCH] Working on PowerPC overflow checks

---
 .../compiler/cfg/intrinsics/intrinsics.factor |  3 +
 basis/cpu/ppc/ppc.factor                      | 58 +++++++++++++++++++
 vm/cpu-ppc.S                                  | 37 ++++++++++++
 3 files changed, 98 insertions(+)

diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index e2c5ea08a6..6c6c2955c9 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -89,6 +89,9 @@ IN: compiler.cfg.intrinsics
         alien.accessors:set-alien-double
     } [ t "intrinsic" set-word-prop ] each ;
 
+: enable-fixnum*-intrinsic ( -- )
+    \ math.private:fixnum* t "intrinsic" set-word-prop ;
+
 : emit-intrinsic ( node word -- node/f )
     {
         { \ kernel.private:tag [ drop emit-tag iterate-next ] }
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 6a42ffdf77..f886a8b45c 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -17,6 +17,7 @@ IN: cpu.ppc
 ! f30, f31: float scratch
 
 enable-float-intrinsics
+enable-fixnum*-intrinsic
 
 << \ ##integer>float t frame-required? set-word-prop
 \ ##float>integer t frame-required? set-word-prop >>
@@ -164,6 +165,63 @@ M: ppc %shr-imm swapd SRWI ;
 M: ppc %sar-imm SRAWI ;
 M: ppc %not     NOT ;
 
+: %alien-invoke-tail ( func dll -- )
+    11 %load-dlsym 11 MTCTR BCTR ;
+
+: exchange-regs ( r1 r2 -- )
+    scratch-reg swap MR scratch-reg MR ;
+
+:: move>args ( src1 src2 -- )
+    {
+        { [ src1 4 = ] [ 3 src2 ?MR 3 4 exchange-regs ] }
+        { [ src1 3 = ] [ 4 src2 ?MR ] }
+        { [ src2 3 = ] [ 4 src1 ?MR 3 4 exchange-regs ] }
+        { [ src2 4 = ] [ 3 src1 ?MR ] }
+        [ 3 src1 MR 4 src2 MR ]
+    } cond ;
+
+:: overflow-check ( src1 src2 insn insn-o func -- )
+    "no-overflow" define-label
+    0 0 LI
+    0 MTXER
+    scratch-reg src1 src2 insn-o execute
+    scratch-reg ds-reg 0 STW
+    "no-overflow" get BNO
+    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
+    0 0 LI
+    0 MTXER
+    scratch-reg src1 src2 insn-o execute
+    "no-overflow" get BNO
+    move>args
+    %prepare-alien-invoke
+    func f %alien-invoke-tail
+    "no-overflow" resolve-label
+    scratch-reg ds-reg 0 STW ; inline
+
+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 ;
+
 : bignum@ ( n -- offset ) cells bignum tag-number - ; inline
 
 M:: ppc %integer>bignum ( dst src temp -- )
diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S
index e12707819a..f7a11f9d12 100755
--- a/vm/cpu-ppc.S
+++ b/vm/cpu-ppc.S
@@ -2,6 +2,43 @@
 in the public domain. */
 #include "asm.h"
 
+#define DS_REG 29
+
+DEF(void,primitive_fixnum_add,(void)):
+    lwz r3,0(DS_REG)
+    lwz r4,-4(DS_REG)
+    subi DS_REG,DS_REG,4
+    li r0,0
+    mtxer r0
+    addo. r5,r3,r4
+    bo MANGLE(overflow_fixnum_add)
+    stw r5,0(DS_REG)
+    blr
+
+DEF(void,primitive_fixnum_subtract,(void)):
+    lwz r3,0(DS_REG)
+    lwz r4,-4(DS_REG)
+    subi DS_REG,DS_REG,4
+    li r0,0
+    mtxer r0
+    subfo. r5,r3,r4
+    bo MANGLE(overflow_fixnum_subtract)
+    stw r5,0(DS_REG)
+    blr
+
+DEF(void,primitive_fixnum_multiply,(void)):
+    lwz r3,0(DS_REG)
+    lwz r4,-4(DS_REG)
+    subi DS_REG,DS_REG,4
+    srawi r3,r3,3
+    mullwo. r5,r3,r4
+    bo multiply_overflow
+    stw r5,0(DS_REG)
+    blr
+multiply_overflow:
+    srawi r4,r4,3
+    jmp MANGLE(overflow_fixnum_multiply)
+    
 /* Note that the XT is passed to the quotation in r11 */
 #define CALL_OR_JUMP_QUOT \
 	lwz r11,9(r3)	   /* load quotation-xt slot */ XX \