various minor additions and PowerPC backend enhancements

library/bootstrap/boot-stage2.factor

@@ -67,6 +67,7 @@ cpu "x86" = [
 cpu "ppc" = [
     "/library/compiler/ppc/assembler.factor"
     "/library/compiler/ppc/generator.factor"
+    "/library/compiler/ppc/slots.factor"
     "/library/compiler/ppc/stack.factor"
     "/library/compiler/ppc/alien.factor"
 ] pull-in

library/collections/assoc.factor

@@ -2,12 +2,10 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: lists USING: kernel sequences ;
 
-! An association list is a list of conses where the car of each
-! cons is a key, and the cdr is a value. See the Factor
-! Developer's Guide for details.
-
 : assoc? ( list -- ? )
-    #! Push if the list appears to be an alist.
+    #! Push if the list appears to be an alist. An association
+    #! list is a list of conses where the car of each cons is a
+    #! key, and the cdr is a value.
     dup list? [ [ cons? ] all? ] [ drop f ] ifte ;
 
 : assoc* ( key alist -- [[ key value ]] )

library/collections/lists.factor

@@ -125,7 +125,7 @@ M: general-list tail ( n list -- tail )
     #! Return the rest of the list, from the nth index onward.
     swap [ cdr ] times ;
 
-M: cons nth ( n list -- element )
+M: general-list nth ( n list -- element )
     over 0 = [ nip car ] [ >r 1 - r> cdr nth ] ifte ;
 
 : intersection ( list list -- list )

library/collections/sequences.factor

@@ -51,6 +51,10 @@ DEFER: <range>
 DEFER: append ! remove this when sort is moved from lists to sequences
 DEFER: subseq
 
+: first 0 swap nth ; inline
+: second 1 swap nth ; inline
+: third 2 swap nth ; inline
+
 ! Some low-level code used by vectors and string buffers.
 IN: kernel-internals
 

library/collections/vectors.factor

@@ -19,8 +19,4 @@ M: vector set-nth ( obj n vec -- )
     growable-check 2dup ensure underlying set-array-nth ;
 
 M: vector hashcode ( vec -- n )
-    dup length 0 number= [
+    dup length 0 number= [ drop 0 ] [ first hashcode ] ifte ;
-        drop 0
-    ] [
-        0 swap nth hashcode
-    ] ifte ;

library/compiler/generator.factor

@@ -56,3 +56,8 @@ M: %target-label generate-node vop-label compile-target ;
 
 M: %target generate-node
     vop-label dup postpone-word  compile-target ;
+
+GENERIC: v>operand
+
+: dest/src ( vop -- dest src )
+    dup vop-out-1 v>operand swap vop-in-1 v>operand ;

library/compiler/ppc/assembler.factor

@@ -26,6 +26,10 @@ USING: compiler errors kernel math memory words ;
 : i-form ( li aa lk -- n )
     >r 1 shift bitor r> bitor ;
 
+: m-form ( s a b mb me -- n )
+    >r 1 shift >r 6 shift >r 11 shift >r 16 shift >r 21 shift
+    r> bitor r> bitor r> bitor r> bitor r> bitor ;
+
 : x-form ( s a b xo rc -- n )
     >r 1 shift >r 11 shift >r 16 shift >r 21 shift
     r> bitor r> bitor r> bitor r> bitor ;
@@ -104,6 +108,20 @@ USING: compiler errors kernel math memory words ;
 : ORC 0 (ORC) ;
 : ORC. 1 (ORC) ;
 
+: (SLW) 24 swap x-form 31 insn ;
+: SLW 0 (SLW) ;
+: SLW. 1 (SLW) ;
+
+: (SRAW) 792 swap x-form 31 insn ;
+: SRAW 0 (SRAW) ;
+: SRAW. 1 (SRAW) ;
+
+: (SRW) 536 swap x-form 31 insn ;
+: SRW 0 (SRW) ;
+: SRW. 1 (SRW) ;
+
+: SRAWI 824 0 x-form 31 insn ;
+
 : XORI d-form 26 insn ;
 : XORIS d-form 27 insn ;
 
@@ -111,7 +129,9 @@ USING: compiler errors kernel math memory words ;
 : XOR 0 (XOR) ;
 : XOR. 1 (XOR) ;
 
-: SRAWI 824 0 x-form 31 insn ;
+: (RLWINM) m-form 21 insn ;
+: RLWINM 0 (RLWINM) ;
+: RLWINM. 1 (RLWINM) ;
 
 : LWZ d-form 32 insn ;
 : STW d-form 36 insn ;
@@ -119,7 +139,7 @@ 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 -rot (B) relative-24 ;
+M: word (B) 0 swap (B) relative-24 ;
 
 : B 0 0 (B) ; : BA 1 0 (B) ; : BL 0 1 (B) ; : BLA 1 1 (B) ;
 

library/compiler/ppc/generator.factor

@@ -11,73 +11,55 @@ lists math memory words ;
 ! r17 executing
 ! r18-r30 vregs
 
-GENERIC: v>operand
 M: integer v>operand tag-bits shift ;
 M: vreg v>operand vreg-n 18 + ;
 
-! At the start of each word that calls a subroutine, we store
-! the link register in r0, then push r0 on the C stack.
 M: %prologue generate-node ( vop -- )
+    #! At the start of each word that calls a subroutine, we
+    #! store the link register in r0, then push r0 on the C
+    #! stack.
     drop
     1 1 -16 STWU
     0 MFLR
     0 1 20 STW ;
 
-! At the end of each word that calls a subroutine, we store
-! the previous link register value in r0 by popping it off the
-! stack, set the link register to the contents of r0, and jump
-! to the link register.
 : compile-epilogue
+    #! At the end of each word that calls a subroutine, we store
+    #! the previous link register value in r0 by popping it off
+    #! the stack, set the link register to the contents of r0,
+    #! and jump to the link register.
     0 1 20 LWZ
     1 1 16 ADDI
     0 MTLR ;
 
-! Far calls are made to addresses already known when the
+M: %call-label generate-node ( vop -- )
-! IR node is being generated. No forward reference far
+    #! Near calling convention for inlined recursive combinators
-! calls are possible.
+    #! Note: length of instruction sequence is hard-coded.
-: compile-call-far ( word -- )
+    vop-label
-    19 LOAD32
-    19 MTLR
-    BLRL ;
-
-: compile-call-label ( label -- )
-    dup primitive? [
-        dup 1 rel-primitive word-xt compile-call-far
-    ] [
-        BL
-    ] ifte ;
-
-: compile-call-label ( word -- )
-    #! Hack: length of instruction sequence that follows
     0 1 rel-address  compiled-offset 20 + 18 LOAD32
     1 1 -16 STWU
     18 1 20 STW
     B ;
 
-M: %call-label generate-node ( vop -- )
+: word-addr ( word -- )
-    vop-label compile-call-label ;
+    dup 0 1 rel-primitive word-xt 19 LOAD32 ;
+
+: compile-call ( label -- )
+    #! Far C call for primitives, near C call for compiled defs.
+    dup primitive? [ word-addr  19 MTLR  BLRL ] [ BL ] ifte ;
 
 M: %call generate-node ( vop -- )
-    vop-label dup postpone-word compile-call-label ;
+    vop-label dup postpone-word compile-call ;
 
-: compile-jump-far ( word -- )
+: compile-jump ( label -- )
-    19 LOAD32
+    #! For tail calls. IP not saved on C stack.
-    19 MTCTR
+    dup primitive? [ word-addr  19 MTCTR  BCTR ] [ B ] ifte ;
-    BCTR ;
-
-: compile-jump-label ( label -- )
-    dup primitive? [
-        dup 1 rel-primitive word-xt compile-jump-far
-    ] [
-        B
-    ] ifte ;
 
 M: %jump generate-node ( vop -- )
-    vop-label dup postpone-word  compile-epilogue
+    vop-label dup postpone-word  compile-epilogue compile-jump ;
-    compile-jump-label ;
 
 M: %jump-label generate-node ( vop -- )
-    vop-label compile-jump-label ;
+    vop-label B ;
 
 : conditional ( vop -- label )
     dup vop-in-1 v>operand 0 swap f address CMPI vop-label ;
@@ -96,6 +78,10 @@ M: %return-to generate-node ( vop -- )
 M: %return generate-node ( vop -- )
     drop compile-epilogue BLR ;
 
+M: %untag generate-node ( vop -- )
+    ! todo: formalize scratch registers
+    dest/src 0 0 28 RLWINM ;
+
 M: %dispatch generate-node ( vop -- )
     ! Compile a piece of code that jumps to an offset in a
     ! jump table indexed by the fixnum at the top of the stack.
@@ -110,9 +96,3 @@ M: %dispatch generate-node ( vop -- )
     18 18 0 LWZ
     18 MTLR
     BLR ;
-
-! \ slot [
-!     PEEK-DS
-!     2unlist type-tag >r cell * r> - >r 18 18 r> LWZ
-!     REPL-DS
-! ] "generator" set-word-prop

library/compiler/ppc/slots.factor

@@ -4,15 +4,32 @@ IN: compiler-backend
 USING: alien assembler compiler inference kernel
 kernel-internals lists math memory namespaces sequences words ;
 
-: userenv ( vreg -- )
+M: %slot generate-node ( vop -- )
+    #! the untagged object is in vop-out-1, the tagged slot
+    #! number is in vop-in-1.
+    dest/src
+    ! turn tagged fixnum slot # into an offset, multiple of 4
+    dup dup 1 SRAWI
+    ! compute slot address in vop-out-1
+    >r dup dup r> ADD
+    ! load slot value in vop-out-1
+    dup 0 LWZ ;
+
+M: %fast-slot generate-node ( vop -- )
+    #! the tagged object is in vop-out-1, the pointer offset is
+    #! in vop-in-1. the offset already takes the type tag
+    #! into account, so its just one instruction to load.
+    dup vop-out-1 v>operand dup rot vop-in-1 LWZ ;
+
+: userenv ( reg -- )
     #! Load the userenv pointer in a virtual register.
-    v>operand "userenv" f dlsym swap LOAD32 0 1 rel-userenv ;
+    "userenv" f dlsym swap LOAD32 0 1 rel-userenv ;
 
 M: %getenv generate-node ( vop -- )
-    dup vop-out-1 v>operand swap vop-in-1
+    dup vop-out-1 v>operand dup userenv
-    [ userenv@ unit MOV ] keep 0 rel-userenv ;
+    dup rot vop-in-1 cell * LWZ ;
 
 M: %setenv generate-node ( vop -- )
-    dup vop-in-2
+    ! bad! need to formalize scratch register usage
-    [ userenv@ unit swap vop-in-1 v>operand MOV ] keep
+    4 <vreg> v>operand dup userenv >r
-    0 rel-userenv ;
+    dup vop-in-1 v>operand r> rot vop-in-2 cell * STW ;

library/compiler/simplifier.factor

@@ -44,7 +44,7 @@ M: %label simplify-node ( linear vop -- linear ? )
     #! If the following op has given class, remove it and
     #! return it.
     over cdr dup [
-        car class = [ cdr car t ] [ f ] ifte
+        car class = [ second t ] [ f ] ifte
     ] [
         3drop f f
     ] ifte ;
@@ -112,7 +112,7 @@ M: %indirect simplify-node ( linear vop -- linear ? )
 : dead-peek? ( linear vop -- ? )
     #! Is the %replace-d followed by a %peek-d of the same
     #! stack slot and vreg?
-    swap cdr car dup %peek-d? [
+    swap second dup %peek-d? [
         over vop-in-2 over vop-out-1 = >r
         swap vop-in-1 swap vop-in-1 = r> and
     ] [

library/compiler/vops.factor

@@ -23,9 +23,9 @@ TUPLE: vreg n ;
 
 ! A virtual operation
 TUPLE: vop inputs outputs label ;
-: vop-in-1 ( vop -- input ) vop-inputs car ;
+: vop-in-1 ( vop -- input ) vop-inputs first ;
-: vop-in-2 ( vop -- input ) vop-inputs cdr car ;
+: vop-in-2 ( vop -- input ) vop-inputs second ;
-: vop-in-3 ( vop -- input ) vop-inputs cdr cdr car ;
+: vop-in-3 ( vop -- input ) vop-inputs third ;
 : vop-out-1 ( vop -- output ) vop-outputs car ;
 
 GENERIC: basic-block? ( vop -- ? )

library/compiler/x86/assembler.factor

@@ -100,10 +100,10 @@ PREDICATE: cons displaced
         drop f
     ] ifte ;
 
-M: displaced modifier cdr car byte? BIN: 01 BIN: 10 ? ;
+M: displaced modifier second byte? BIN: 01 BIN: 10 ? ;
 M: displaced register car register ;
 M: displaced displacement
-    cdr car dup byte? [ compile-byte ] [ compile-cell ] ifte ;
+    second dup byte? [ compile-byte ] [ compile-cell ] ifte ;
 
 ( Displacement-only operands -- eg, [ 1234 ]                   )
 PREDICATE: cons disp-only
@@ -156,11 +156,6 @@ UNION: operand register indirect displaced disp-only ;
     #! Relative to after next 32-bit immediate.
     compiled-offset - 4 - ;
 
-: patch ( addr where -- )
-    #! Encode a relative offset to addr from where at where.
-    #! Add 4 because addr is relative to *after* insn.
-    dup >r 4 + - r> set-compiled-cell ;
-
 ( Moving stuff                                                 )
 GENERIC: PUSH ( op -- )
 M: register PUSH HEX: 50 1-operand-short ;

library/compiler/x86/generator.factor

@@ -4,13 +4,9 @@ IN: compiler-backend
 USING: alien assembler compiler inference kernel
 kernel-internals lists math memory namespaces sequences words ;
 
-GENERIC: v>operand
 M: integer v>operand tag-bits shift ;
 M: vreg v>operand vreg-n { EAX ECX EDX } nth ;
 
-: dest/src ( vop -- dest src )
-    dup vop-out-1 v>operand swap vop-in-1 v>operand ;
-
 ! Not used on x86
 M: %prologue generate-node drop ;
 

library/generic/tuple.factor

@@ -202,7 +202,7 @@ M: tuple hashcode ( vec -- n )
     dup length 2 number= [
         drop 0
     ] [
-        2 swap nth hashcode
+        2 swap array-nth hashcode
     ] ifte ;
 
 M: tuple = ( obj tuple -- ? )

library/inference/inference.factor

@@ -52,7 +52,7 @@ SYMBOL: d-in
     over car ensure-d
     -rot 2dup car length 0 rot node-inputs
     2slip
-    cdr car length 0 rot node-outputs ; inline
+    second length 0 rot node-outputs ; inline
 
 : (present-effect) ( vector -- list )
     >list [ value-class ] map ;

library/io/files.factor

@@ -8,6 +8,6 @@ USING: kernel lists sequences strings ;
 : exists? ( file -- ? ) stat >boolean ;
 : directory? ( file -- ? ) stat car ;
 : directory ( dir -- list ) (directory) [ string> ] sort ;
-: file-length ( file -- length ) stat cdr cdr car ;
+: file-length ( file -- length ) stat third ;
 : file-extension ( filename -- extension )
     "." split cdr dup [ peek ] when ;

library/io/stream.factor

@@ -24,7 +24,7 @@ GENERIC: stream-close      ( stream -- )
 GENERIC: set-timeout       ( timeout stream -- )
 
 : stream-read1 ( stream -- char/f )
-    1 swap stream-read dup empty? [ drop f ] [ 0 swap nth ] ifte ;
+    1 swap stream-read dup empty? [ drop f ] [ first ] ifte ;
 
 : stream-write ( string stream -- )
     f swap stream-write-attr ;

library/math/math.factor

@@ -89,4 +89,8 @@ GENERIC: abs ( z -- |z| )
 
 : log2 ( n -- b )
     #! Log base two for integers.
-    dup 1 = [ drop 0 ] [ 2 /i log2 1 + ] ifte ;
+    dup 0 < [
+        "Input must be positive" throw
+    ] [
+        dup 1 = [ drop 0 ] [ 2 /i log2 1 + ] ifte
+    ] ifte ;

library/math/matrices.factor

@@ -12,9 +12,12 @@ vectors ;
 : v* ( v v -- v ) [ * ] 2map ;
 : v** ( v v -- v ) [ conjugate * ] 2map ;
 
+: sum ( v -- n ) 0 swap [ + ] each ;
+: product 1 swap [ * ] each ;
+
 ! Later, this will fixed when 2each works properly
 ! : v. ( v v -- x ) 0 swap [ conjugate * + ] 2each ;
-: v. ( v v -- x ) v** 0 swap [ + ] each ;
+: v. ( v v -- x ) v** sum ;
 
 : cross-trace ( v1 v2 i1 i2 -- v1 v2 n )
     pick nth >r pick nth r> * ;
@@ -53,11 +56,11 @@ M: matrix clone ( matrix -- matrix )
 : <zero-matrix> ( rows cols -- matrix )
     2dup * zero-vector <matrix> ;
 
-: <row-vector> ( vector -- matrix )
+: <row-matrix> ( vector -- matrix )
     #! Turn a vector into a matrix of one row.
     [ 1 swap length ] keep <matrix> ;
 
-: <col-vector> ( vector -- matrix )
+: <col-matrix> ( vector -- matrix )
     #! Turn a vector into a matrix of one column.
     [ length 1 ] keep <matrix> ;
 
@@ -79,16 +82,31 @@ M: matrix clone ( matrix -- matrix )
 TUPLE: row index matrix ;
 : >row< dup row-index swap row-matrix ;
 M: row length row-matrix matrix-cols ;
-M: row nth ( n row -- ) >row< swapd matrix-get ;
+M: row nth ( n row -- n ) >row< swapd matrix-get ;
 M: row thaw >vector ;
 
 ! Sequence of elements in a column of a matrix.
 TUPLE: col index matrix ;
 : >col< dup col-index swap col-matrix ;
 M: col length col-matrix matrix-rows ;
-M: col nth ( n column -- ) >col< matrix-get ;
+M: col nth ( n column -- n ) >col< matrix-get ;
 M: col thaw >vector ;
 
+! Sequence of elements on a diagonal. Positive indices are above
+! and negative indices are below the main diagonal. Only for
+! square matrices.
+TUPLE: diagonal index matrix ;
+: >diagonal< dup diagonal-index swap diagonal-matrix ;
+M: diagonal length ( daig -- n )
+    >diagonal< matrix-rows swap abs - ;
+M: diagonal nth ( n diag -- n )
+    >diagonal< >r [ neg 0 max over + ] keep 0 max rot + r>
+    matrix-get ;
+
+: trace ( matrix -- tr )
+    #! Product of diagonal elements.
+    0 swap <diagonal> product ;
+
 : +check ( matrix matrix -- )
     #! Check if the two matrices have dimensions compatible
     #! for being added or subtracted.
@@ -131,11 +149,11 @@ M: col thaw >vector ;
 
 : m.v ( m v -- v )
     #! Multiply a matrix by a column vector.
-    <col-vector> m. matrix-sequence ;
+    <col-matrix> m. matrix-sequence ;
 
 : v.m ( v m -- v )
     #! Multiply a row vector by a matrix.
-    >r <row-vector> r> m. matrix-sequence ;
+    >r <row-matrix> r> m. matrix-sequence ;
 
 : row-list ( matrix -- list )
     #! A list of lists, where each sublist is a row of the

library/syntax/prettyprint.factor

@@ -69,7 +69,7 @@ M: word prettyprint* ( indent word -- indent )
     #! Is the head of the list a [ foo ] car?
     dup car dup cons? [
         dup car word? [
-            cdr [ drop f ] [ cdr car \ car = ] ifte
+            cdr [ drop f ] [ second \ car = ] ifte
         ] [
             2drop f
         ] ifte

library/test/math/matrices.factor

@@ -1,5 +1,5 @@
 IN: temporary
-USING: kernel lists math matrices namespaces test ;
+USING: kernel lists math matrices namespaces sequences test ;
 
 [ [ [ 1 4 ] [ 2 5 ] [ 3 6 ] ] ]
 [ M[ [ 1 4 ] [ 2 5 ] [ 3 6 ] ]M row-list ] unit-test
@@ -129,3 +129,10 @@ unit-test
     
     m.
 ] unit-test
+
+[
+    [ [ 7 ] [ 4 8 ] [ 1 5 9 ] [ 2 6 ] [ 3 ] ]
+] [
+    M[ [ 1 2 3 ] [ 4 5 6 ] [ 7 8 9 ] ]M
+    5 [ 2 - swap <diagonal> ] project-with [ >list ] map
+] unit-test

library/test/sbuf.factor

@@ -13,7 +13,7 @@ USING: kernel math namespaces sequences strings test ;
 
 [ CHAR: h ] [ 0 SBUF" hello world" nth ] unit-test
 [ CHAR: H ] [
-    CHAR: H 0 SBUF" hello world" [ set-nth ] keep 0 swap nth
+    CHAR: H 0 SBUF" hello world" [ set-nth ] keep first
 ] unit-test
 
 [ SBUF" x" ] [ 1 <sbuf> CHAR: x >bignum over push ] unit-test

library/test/tuple.factor

@@ -72,3 +72,7 @@ M: circle area circle-radius sq pi * ;
 [ 200 ] [ << rect f 0 0 10 20 >> area ] unit-test
 
 [ ] [ "IN: temporary  SYMBOL: #x  TUPLE: #x ;" eval ] unit-test
+
+! Hashcode breakage
+TUPLE: empty ;
+[ t ] [ <empty> hashcode fixnum? ] unit-test

library/ui/inspector.factor

@@ -31,7 +31,7 @@ lists namespaces sequences strings unparser vectors words ;
 
 : object>alist ( obj -- assoc )
     dup class "slots" word-prop [
-        cdr car [ execute ] keep swons
+        second [ execute ] keep swons
     ] map-with ;
 
 : slot-sheet ( obj -- sheet )

library/unix/io.factor

@@ -356,9 +356,7 @@ M: write-task io-task-events ( task -- events )
     ] ifte* ;
 
 M: writer stream-flush ( stream -- )
-    [
+    [ swap <write-task> add-write-io-task stop ] callcc0 drop ;
-        swap <write-task> add-write-io-task stop
-    ] callcc0 drop ;
 
 M: writer stream-auto-flush ( stream -- ) drop ;