various PowerPC generator fixes

diff --git a/factor/jedit/FactorPlugin.java b/factor/jedit/FactorPlugin.java
index 80ff5bf16d1587800f514c57d3e0a021a9d313fc..002bcd69f4622c02f37ae2e643f07e9099f91a14 100644 (file)
--- a/factor/jedit/FactorPlugin.java
+++ b/factor/jedit/FactorPlugin.java
@@ -114,11 +114,13 @@ public class FactorPlugin extends EditPlugin
                                "factor.external.args")
                                .split(" ");
                        addNonEmpty(extraArgs,args);
+                       String[] argsArray = (String[])args.toArray(
+                               new String[args.size()]);
+                       for(int i = 0; i < argsArray.length; i++)
+                               System.out.println(argsArray[i]);
+
                        process = Runtime.getRuntime().exec(
-                               (String[])args.toArray(
-                               new String[args.size()]),
-                               null,
-                               new File(MiscUtilities
+                               argsArray, null, new File(MiscUtilities
                                .getParentOfPath(imagePath)));
 
                        process.getOutputStream().close();

diff --git a/library/collections/lists.factor b/library/collections/lists.factor
index eb1da32e09dc9a607060c97924243a65c1af45a1..319748d36e4a0101c6a1a8336f83db64c076ad7d 100644 (file)
--- a/library/collections/lists.factor
+++ b/library/collections/lists.factor
@@ -126,7 +126,7 @@ M: general-list tail ( n list -- tail )
     swap [ cdr ] times ;
 
 M: general-list nth ( n list -- element )
-    over 0 = [ nip car ] [ >r 1 - r> cdr nth ] ifte ;
+    over 0 number= [ nip car ] [ >r 1 - r> cdr nth ] ifte ;
 
 : intersection ( list list -- list )
     #! Make a list of elements that occur in both lists.

diff --git a/library/compiler/generator.factor b/library/compiler/generator.factor
index b23bea0e75846652b742e3b719b74adccffd3ca6..2ad15605a943921831fa8d21dd754de1dc712145 100644 (file)
--- a/library/compiler/generator.factor
+++ b/library/compiler/generator.factor
@@ -65,3 +65,7 @@ GENERIC: v>operand
 ! These constants must match native/card.h
 : card-bits 7 ;
 : card-mark HEX: 80 ;
+
+: shift-add ( by -- n )
+    #! Used in fixnum-shift overflow check.
+    1 swap cell 8 * swap 1 - - shift ;

diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index 9e61e42fe5fbcc6f211a2891b306a67a563ec802..dd3250f5128a567365d00ee9863a62f13678dccc 100644 (file)
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -5,6 +5,11 @@ USING: assembler compiler-backend generic hashtables inference
 kernel kernel-internals lists math math-internals namespaces
 sequences words ;
 
+! Architecture description
+: fixnum-imm?
+    #! Can fixnum operations take immediate operands?
+    cpu "x86" = ;
+
 \ dup [
     drop
     in-1
@@ -138,16 +143,22 @@ sequences words ;
 : literal-fixnum? ( value -- ? )
     dup literal? [ literal-value fixnum? ] [ drop f ] ifte ;
 
+: binary-op-imm ( node imm op out -- )
+    >r >r 1 %dec-d ,
+    in-1
+    0 <vreg> dup r> execute ,
+    r> 0 %replace-d , ;
+
 : binary-op ( node op out -- )
     #! out is a vreg where the vop stores the result.
-    >r >r node-peek dup literal-fixnum? [
-        1 %dec-d ,
-        in-1
-        literal-value 0 <vreg> 0 <vreg> r> execute ,
-        r> 0 %replace-d ,
+    fixnum-imm? [
+        >r >r node-peek dup literal-fixnum? [
+            literal-value r> r> binary-op-imm
+        ] [
+            drop r> r> binary-op-reg
+        ] ifte
     ] [
-        drop
-        r> r> binary-op-reg
+        binary-op-reg drop
     ] ifte ;
 
 [

diff --git a/library/compiler/ppc/assembler.factor b/library/compiler/ppc/assembler.factor
index 9a3a9311f7be64217244e388ac486eea4435315a..52cd0954679081fa66bf89427a47bd38b3d7dcba 100644 (file)
--- a/library/compiler/ppc/assembler.factor
+++ b/library/compiler/ppc/assembler.factor
@@ -38,7 +38,7 @@ USING: compiler errors kernel math memory words ;
 : xfx-form ( d spr xo -- n )
     1 shift >r 11 shift >r 21 shift r> bitor r> bitor ;
 
-: xo-form ( d a b oe xo rc -- n )
+: xo-form ( d a b oe rc xo -- n )
     swap
     >r 1 shift >r 10 shift >r 11 shift >r 16 shift >r 21 shift
     r> bitor r> bitor r> bitor r> bitor r> bitor ;
@@ -129,8 +129,8 @@ USING: compiler errors kernel math memory words ;
 : (MULLW) 235 xo-form 31 insn ;
 : MULLW 0 0 (MULLW) ;
 : MULLW. 0 1 (MULLW) ;
-: MULLWC 1 0 (MULLW) ;
-: MULLWC. 1 1 (MULLW) ;
+: MULLWO 1 0 (MULLW) ;
+: MULLWO. 1 1 (MULLW) ;
 
 : (SLW) 24 x-form 31 insn ;
 : SLW 0 (SLW) ;

diff --git a/library/compiler/ppc/fixnum.factor b/library/compiler/ppc/fixnum.factor
index 42ea912f24b356d1b05c9e697eab00b6645ab869..78963aa90ff1e7e8111719c31969801b4cd78ca4 100644 (file)
--- a/library/compiler/ppc/fixnum.factor
+++ b/library/compiler/ppc/fixnum.factor
@@ -4,28 +4,24 @@ IN: compiler-backend
 USING: assembler compiler kernel math math-internals memory
 namespaces words ;
 
-: >3-vop< ( vop -- out1 in2 in1 )
+: >3-imm< ( vop -- out1 in2 in1 )
     [ vop-out-1 v>operand ] keep
     [ vop-in-2 v>operand ] keep
     vop-in-1 ;
 
-: maybe-immediate ( vop imm comp -- )
-    pick vop-in-1 integer? [
-        >r >r >3-vop< v>operand r> execute r> drop
-    ] [
-        >r >r >3-vop< v>operand swap r> drop r> execute
-    ] ifte ; inline
+: >3-vop< ( vop -- out1 in1 in2 )
+    >3-imm< v>operand swap ;
 
 : simple-overflow ( vop inv word -- )
     >r >r
     <label> "end" set
     "end" get BNO
-    dup >3-vop< v>operand 3dup swapd r> execute
+    dup >3-vop< 3dup r> execute
     2dup
     dup tag-bits SRAWI
     dup tag-bits SRAWI
-    drop
     3 -rot r> execute
+    drop
     "s48_long_to_bignum" f compile-c-call
     ! An untagged pointer to the bignum is now in r3; tag it
     3 swap vop-out-1 v>operand bignum-tag ORI
@@ -33,20 +29,33 @@ namespaces words ;
 
 M: %fixnum+ generate-node ( vop -- )
     0 MTXER
-    dup \ ADDI \ ADDO. maybe-immediate
+    dup >3-vop< ADDO.
     \ SUBF \ ADD simple-overflow ;
 
 M: %fixnum- generate-node ( vop -- )
     0 MTXER
-    dup \ SUBI \ SUBFO. maybe-immediate
+    dup >3-vop< SUBFO.
     \ ADD \ SUBF simple-overflow ;
 
 M: %fixnum* generate-node ( vop -- )
-    dup \ MULLI \ MULLW maybe-immediate
-    vop-out-1 v>operand dup tag-bits SRAWI ;
+    dup >3-vop< dup dup tag-bits SRAWI
+    0 MTXER
+    [ >r >r drop 4 r> r> MULLWO. 3 ] 2keep
+    <label> "end" set
+    "end" get BNO
+    MULHW
+    "s48_long_long_to_bignum" f compile-c-call
+    ! now we have to shift it by three bits to remove the second
+    ! tag
+    tag-bits neg 4 LI
+    "s48_bignum_arithmetic_shift" f compile-c-call
+    ! An untagged pointer to the bignum is now in r3; tag it
+    3 4 bignum-tag ORI
+    "end" get save-xt
+    vop-out-1 v>operand 4 MR ;
 
 M: %fixnum/i generate-node ( vop -- )
-    dup >3-vop< v>operand DIVW
+    dup >3-vop< swap DIVW
     vop-out-1 v>operand dup tag-fixnum ;
 
 : generate-fixnum/mod ( -- )
@@ -69,23 +78,43 @@ M: %fixnum/mod generate-node ( vop -- )
     17 17 tag-fixnum ;
 
 M: %fixnum-bitand generate-node ( vop -- )
-    \ ANDI \ AND maybe-immediate ;
+    >3-vop< AND ;
 
 M: %fixnum-bitor generate-node ( vop -- )
-    \ ORI \ OR maybe-immediate ;
+    >3-vop< OR ;
 
 M: %fixnum-bitxor generate-node ( vop -- )
-    \ XORI \ XOR maybe-immediate ;
+    >3-vop< XOR ;
 
 M: %fixnum-bitnot generate-node ( vop -- )
     dest/src dupd NOT dup untag ;
 
 M: %fixnum<< generate-node ( vop -- )
-    dup vop-in-1 20 LI
-    dup vop-out-1 v>operand swap vop-in-2 v>operand 20 SLW ;
+    ! This has specific register requirements.
+    <label> "no-overflow" set
+    <label> "end" set
+    vop-in-1
+    ! check for potential overflow
+    dup shift-add dup 19 LOAD
+    18 17 19 ADD
+    0 18 rot 2 * 1 - CMPLI
+    ! is there going to be an overflow?
+    "no-overflow" get BGE
+    ! there is going to be an overflow, make a bignum
+    3 17 tag-bits SRAWI
+    "s48_long_to_bignum" f compile-c-call
+    dup 4 LI
+    "s48_bignum_arithmetic_shift" f compile-c-call
+    ! tag the result
+    3 17 bignum-tag ORI
+    "end" get B
+    ! there is not going to be an overflow
+    "no-overflow" get save-xt
+    17 17 rot SLWI
+    "end" get save-xt ;
 
 M: %fixnum>> generate-node ( vop -- )
-    >3-vop< >r dupd r> SRAWI dup untag ;
+    >3-imm< pick >r SRAWI r> dup untag ;
 
 M: %fixnum-sgn generate-node ( vop -- )
     dest/src dupd 31 SRAWI dup untag ;

diff --git a/library/compiler/ppc/generator.factor b/library/compiler/ppc/generator.factor
index 8cfca6b8501e2813e7eafb9e45b59c475d38c393..034d8983da3a91ab75d73dd430cc5ad3fb506a2e 100644 (file)
--- a/library/compiler/ppc/generator.factor
+++ b/library/compiler/ppc/generator.factor
@@ -129,15 +129,16 @@ M: %arithmetic-type generate-node ( vop -- )
     0 <vreg> check-dest
     <label> "end" set
     ! Load top two stack values
-    17 14 -4 LWZ
-    18 14 0 LWZ
+    3 14 -4 LWZ
+    4 14 0 LWZ
     ! Compute their tags
-    17 17 tag-mask ANDI
-    18 18 tag-mask ANDI
+    3 3 tag-mask ANDI
+    4 4 tag-mask ANDI
     ! Are the tags equal?
-    0 17 18 CMPL
+    0 3 3 CMPL
     "end" get BEQ
     ! No, they are not equal. Call a runtime function to
     ! coerce the integers to a higher type.
     "arithmetic_type" f compile-c-call
-    "end" get save-xt ;
+    "end" get save-xt
+    17 3 MR ;

diff --git a/library/compiler/x86/fixnum.factor b/library/compiler/x86/fixnum.factor
index b74871e17ce435766100539a3fd5de574d022315..413f6f9273ccb1a5182e0d4045ac168f81cfd8d3 100644 (file)
--- a/library/compiler/x86/fixnum.factor
+++ b/library/compiler/x86/fixnum.factor
@@ -124,7 +124,7 @@ M: %fixnum<< generate-node
     ECX EAX MOV
     vop-in-1
     ! check for potential overflow
-    1 over cell 8 * swap 1 - - shift ECX over ADD
+    dup shift-add ECX over ADD
     2 * 1 - ECX swap CMP
     ! is there going to be an overflow?
     "no-overflow" get JBE

diff --git a/library/compiler/xt.factor b/library/compiler/xt.factor
index 73e84d2f0d85c502d2be2e014697a6868521c1f6..fa70a0fc071d8b29bc77836feca10ae60190614d 100644 (file)
--- a/library/compiler/xt.factor
+++ b/library/compiler/xt.factor
@@ -134,7 +134,13 @@ M: absolute-16/16 fixup ( absolute -- ) >absolute fixup-16/16 ;
     deferred-xts get [ fixup ] each  deferred-xts off ;
 
 : with-compiler ( quot -- )
-    [ call  fixup-xts  commit-xts ] with-scope ;
+    [
+        deferred-xts off
+        compiled-xts off
+        call
+        fixup-xts
+        commit-xts
+    ] with-scope ;
 
 : postpone-word ( word -- )
     dup compiling? [