powerpc fixes

TODO.FACTOR.txt

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

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 ;
-
-\ fixnum* [
-    ! Turn multiplication by a power of two into a left shift.
-    node-peek dup literal-fixnum? [
-        literal-value dup power-of-2? [
+: fast-fixnum* ( n -- )
     1 %dec-d ,
     in-1
     log2 0 <vreg> 0 <vreg> %fixnum<< ,
-            0 0 %replace-d ,
+    0 0 %replace-d , ;
+
+: slow-fixnum* ( node -- ) \ %fixnum* binary-op-reg ;
+
+\ fixnum* [
+    ! Turn multiplication by a power of two into a left shift.
+    dup node-peek dup literal-fixnum? [
+        literal-value dup power-of-2? [
+            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 [

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 ;

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.

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