cpu "ppc" = [\r
"/library/compiler/ppc/assembler.factor"\r
"/library/compiler/ppc/generator.factor"\r
+ "/library/compiler/ppc/slots.factor"\r
"/library/compiler/ppc/stack.factor"\r
"/library/compiler/ppc/alien.factor"\r
] pull-in\r
! 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 ]] )
#! 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 )
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
growable-check 2dup ensure underlying set-array-nth ;
M: vector hashcode ( vec -- n )
- dup length 0 number= [
- drop 0
- ] [
- 0 swap nth hashcode
- ] ifte ;
+ dup length 0 number= [ drop 0 ] [ first hashcode ] ifte ;
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 ;
: 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 ;
: 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 ;
: 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 ;
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) ;
! 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
-! IR node is being generated. No forward reference far
-! calls are possible.
-: compile-call-far ( word -- )
- 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
+M: %call-label generate-node ( vop -- )
+ #! Near calling convention for inlined recursive combinators
+ #! Note: length of instruction sequence is hard-coded.
+ vop-label
0 1 rel-address compiled-offset 20 + 18 LOAD32
1 1 -16 STWU
18 1 20 STW
B ;
-M: %call-label generate-node ( vop -- )
- vop-label compile-call-label ;
+: word-addr ( word -- )
+ dup 0 1 rel-primitive word-xt 19 LOAD32 ;
-M: %call generate-node ( vop -- )
- vop-label dup postpone-word compile-call-label ;
+: compile-call ( label -- )
+ #! Far C call for primitives, near C call for compiled defs.
+ dup primitive? [ word-addr 19 MTLR BLRL ] [ BL ] ifte ;
-: compile-jump-far ( word -- )
- 19 LOAD32
- 19 MTCTR
- BCTR ;
+M: %call generate-node ( vop -- )
+ vop-label dup postpone-word compile-call ;
-: compile-jump-label ( label -- )
- dup primitive? [
- dup 1 rel-primitive word-xt compile-jump-far
- ] [
- B
- ] ifte ;
+: compile-jump ( label -- )
+ #! For tail calls. IP not saved on C stack.
+ dup primitive? [ word-addr 19 MTCTR BCTR ] [ B ] ifte ;
M: %jump generate-node ( vop -- )
- vop-label dup postpone-word compile-epilogue
- compile-jump-label ;
+ vop-label dup postpone-word compile-epilogue compile-jump ;
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 ;
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.
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
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
- [ userenv@ unit MOV ] keep 0 rel-userenv ;
+ dup vop-out-1 v>operand dup userenv
+ dup rot vop-in-1 cell * LWZ ;
M: %setenv generate-node ( vop -- )
- dup vop-in-2
- [ userenv@ unit swap vop-in-1 v>operand MOV ] keep
- 0 rel-userenv ;
+ ! bad! need to formalize scratch register usage
+ 4 <vreg> v>operand dup userenv >r
+ dup vop-in-1 v>operand r> rot vop-in-2 cell * STW ;
#! 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 ;
: 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
] [
! A virtual operation
TUPLE: vop inputs outputs label ;
-: vop-in-1 ( vop -- input ) vop-inputs car ;
-: vop-in-2 ( vop -- input ) vop-inputs cdr car ;
-: vop-in-3 ( vop -- input ) vop-inputs cdr cdr car ;
+: vop-in-1 ( vop -- input ) vop-inputs first ;
+: vop-in-2 ( vop -- input ) vop-inputs second ;
+: vop-in-3 ( vop -- input ) vop-inputs third ;
: vop-out-1 ( vop -- output ) vop-outputs car ;
GENERIC: basic-block? ( vop -- ? )
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
#! 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 ;
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 ;
dup length 2 number= [
drop 0
] [
- 2 swap nth hashcode
+ 2 swap array-nth hashcode
] ifte ;
M: tuple = ( obj tuple -- ? )
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 ;
: 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 ;
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 ;
: 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 ;
: 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> * ;
: <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> ;
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.
: 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
#! 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
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
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
[ 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
[ 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
: object>alist ( obj -- assoc )
dup class "slots" word-prop [
- cdr car [ execute ] keep swons
+ second [ execute ] keep swons
] map-with ;
: slot-sheet ( obj -- sheet )
] 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 ;
projects / factor.git / commitdiff