powerpc fixes

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index b239d07f46eb490dbbb074634c190d78a4597d96..379901422074ddbdbebe57def4c9f837d0d79e99 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -6,13 +6,14 @@
 <magnus--> http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html\r
 <magnus--> http://clozure.com/cgi-bin/viewcvs.cgi/ccl/lisp-kernel/lisp-exceptions.c?rev=1.9&content-type=text/vnd.viewcvs-markup\r
 \r
+- make head? tail? more efficient with slices\r
 - fix ceiling\r
 - single-stepper and variable access: wrong namespace?\r
 - investigate if COPYING_GEN needs a fix\r
 - faster layout\r
 - keep alive\r
 - sleep word\r
-- redo new compiler backend for PowerPC\r
+- fix fixnum<< overflow on PowerPC\r
 - fix i/o on generic x86/ppc unix\r
 - alien primitives need a more general input type\r
 - 2map slow with lists\r
@@ -66,7 +67,6 @@
 + compiler:\r
 \r
 - simplifier:\r
-  - kill tag-fixnum/untag-fixnum\r
   - kill replace after a peek\r
   - merge inc-d's across VOPs that don't touch the stack\r
 - [ EAX 0 ] --> [ EAX ]\r

diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index dd3250f5128a567365d00ee9863a62f13678dccc..fc993b9792d1b5deaa0997dc31b33eff2462b7c4 100644 (file)
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -134,31 +134,49 @@ sequences words ;
     1 %dec-d ,
 ] "intrinsic" set-word-prop
 
-: binary-op-reg ( op out -- )
-    >r in-2
-    1 %dec-d ,
-    >r 1 <vreg> 0 <vreg> 0 <vreg> r> execute ,
-    r> 0 %replace-d , ;
+GENERIC: load-value ( vreg n value -- )
+
+M: computed load-value ( vreg n value -- )
+    drop %peek-d , ;
+
+M: literal load-value ( vreg n value -- )
+    nip literal-value %immediate , ;
+
+: value/vreg-list ( in -- list )
+    [ 0 swap length 1 - ] keep
+    [ >r 2dup r> 3list >r 1 - >r 1 + r> r> ] map 2nip ;
+
+: values>vregs ( in -- in )
+    value/vreg-list
+    dup [ 3unlist load-value ] each
+    [ car <vreg> ] map ;
+
+: load-inputs ( node -- in )
+    dup node-in-d values>vregs
+    [ length swap node-out-d length - %dec-d , ] keep ;
+
+: binary-op-reg ( node op -- )
+    >r load-inputs 2unlist swap dup r> execute ,
+    0 0 %replace-d , ; inline
 
 : 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-imm ( imm op -- )
+    1 %dec-d , in-1
+    >r 0 <vreg> dup r> execute ,
+    0 0 %replace-d , ; inline
 
-: binary-op ( node op out -- )
+: binary-op ( node op -- )
     #! out is a vreg where the vop stores the result.
     fixnum-imm? [
-        >r >r node-peek dup literal-fixnum? [
-            literal-value r> r> binary-op-imm
+        >r dup node-peek dup literal-fixnum? [
+            literal-value r> binary-op-imm drop
         ] [
-            drop r> r> binary-op-reg
+            drop r> binary-op-reg
         ] ifte
     ] [
-        binary-op-reg drop
+        binary-op-reg
     ] ifte ;
 
 [
@@ -173,20 +191,23 @@ sequences words ;
     [[ fixnum>       %fixnum>       ]]
     [[ eq?           %eq?           ]]
 ] [
-    uncons [ literal, 0 , \ binary-op , ] make-list
+    uncons [ literal, \ binary-op , ] make-list
     "intrinsic" set-word-prop
 ] each
 
-: slow-fixnum* \ %fixnum* 0 binary-op-reg ;
+: fast-fixnum* ( n -- )
+    1 %dec-d ,
+    in-1
+    log2 0 <vreg> 0 <vreg> %fixnum<< ,
+    0 0 %replace-d , ;
+
+: slow-fixnum* ( node -- ) \ %fixnum* binary-op-reg ;
 
 \ fixnum* [
     ! Turn multiplication by a power of two into a left shift.
-    node-peek dup literal-fixnum? [
+    dup node-peek dup literal-fixnum? [
         literal-value dup power-of-2? [
-            1 %dec-d ,
-            in-1
-            log2 0 <vreg> 0 <vreg> %fixnum<< ,
-            0 0 %replace-d ,
+            nip fast-fixnum*
         ] [
             drop slow-fixnum*
         ] ifte
@@ -209,7 +230,7 @@ sequences words ;
 \ fixnum/i t "intrinsic" set-word-prop
 
 \ fixnum/i [
-    drop \ %fixnum/i 0 binary-op-reg
+    \ %fixnum/i binary-op-reg
 ] "intrinsic" set-word-prop
 
 \ fixnum/mod [

diff --git a/library/compiler/ppc/assembler.factor b/library/compiler/ppc/assembler.factor
index 9f500b5ed23ef7c596101745043374616492a54b..637c096a82f7501619ccfab265594caa073e7482 100644 (file)
--- a/library/compiler/ppc/assembler.factor
+++ b/library/compiler/ppc/assembler.factor
@@ -195,9 +195,9 @@ USING: compiler errors kernel math memory words ;
 
 G: (B) ( dest aa lk -- ) [ pick ] [ type ] ;
 M: integer (B) i-form 18 insn ;
-M: word (B) 0 (B) relative-24 ;
+M: word (B) 0 -rot (B) relative-24 ;
 
-: B 0 0 (B) ; : BA 1 0 (B) ; : BL 0 1 (B) ; : BLA 1 1 (B) ;
+: B 0 0 (B) ; : BL 0 1 (B) ;
 
 GENERIC: BC
 M: integer BC 0 0 b-form 16 insn ;

diff --git a/library/compiler/ppc/generator.factor b/library/compiler/ppc/generator.factor
index 56a4b3739d986c9d8d4c3e7c9afc601a5c8d55c0..b3f4d3a243e2fc51a2e29ca665b7b2f77526b764 100644 (file)
--- a/library/compiler/ppc/generator.factor
+++ b/library/compiler/ppc/generator.factor
@@ -10,7 +10,7 @@ kernel-internals lists math memory namespaces words ;
 ! r16-r30 vregs
 
 : compile-c-call ( symbol dll -- )
-    2dup 1 1 rel-dlsym dlsym  19 LOAD32  19 MTLR  BLRL ;
+    2dup dlsym  19 LOAD32  0 1 rel-dlsym  19 MTLR  BLRL ;
 
 M: integer v>operand tag-bits shift ;
 M: vreg v>operand vreg-n 17 + ;
@@ -135,7 +135,7 @@ M: %arithmetic-type generate-node ( vop -- )
     3 3 tag-mask ANDI
     4 4 tag-mask ANDI
     ! Are the tags equal?
-    0 3 3 CMPL
+    0 3 4 CMPL
     "end" get BEQ
     ! No, they are not equal. Call a runtime function to
     ! coerce the integers to a higher type.

diff --git a/library/compiler/simplifier.factor b/library/compiler/simplifier.factor
index 48cdd4db126e0f114b4a7a8cead6dd35c2c9958b..f1885884ae79f40bf413b2a19f1bd802640b0605 100644 (file)
--- a/library/compiler/simplifier.factor
+++ b/library/compiler/simplifier.factor
@@ -62,6 +62,18 @@ M: %inc-d simplify-node ( linear vop -- linear ? )
         ] ifte
     ] ifte ;
 
+: operands= ( vop vop -- ? )
+    over vop-inputs over vop-inputs =
+    >r swap vop-outputs swap vop-outputs = r> and ;
+
+: cancel ( linear class -- linear ? )
+    dupd next-physical?
+    [ over first operands= [ cdr cdr t ] [ f ] ifte ]
+    [ drop f ] ifte ;
+
+M: %tag-fixnum simplify-node ( linear vop -- linear ? )
+    drop \ %untag-fixnum cancel ;
+
 : basic-block ( linear quot -- | quot: vop -- ? )
     #! Keep applying the quotation to each VOP until either a
     #! VOP answering f to basic-block?, or the quotation answers