steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Aaron Schaefer 2008-11-05 23:05:37 -05:00
parent 15257b91ac fbb958da82
commit c9449cf3f5
40 changed files with 925 additions and 1335 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
basis/compiler/cfg/linear-scan/debugger/debugger.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences sets arrays
compiler.cfg.linear-scan.live-intervals
USING: accessors kernel sequences sets arrays math strings fry
prettyprint compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation ;
IN: compiler.cfg.linear-scan.debugger
@ -21,3 +21,16 @@ IN: compiler.cfg.linear-scan.debugger
: check-linear-scan ( live-intervals machine-registers -- )
[ [ clone ] map ] dip allocate-registers
[ split-children ] map concat check-assigned ;
: picture ( uses -- str )
dup peek 1 + CHAR: space <string>
[ '[ CHAR: * swap _ set-nth ] each ] keep ;
: interval-picture ( interval -- str )
[ uses>> picture ]
[ copy-from>> unparse ]
[ vreg>> unparse ]
tri 3array ;
: live-intervals. ( seq -- )
[ interval-picture ] map simple-table. ;

2
basis/compiler/codegen/codegen.factor
View File

@ -152,7 +152,7 @@ M: ##not generate-insn dst/src %not ;
[ dst/src ] [ temp>> register ] bi ; inline
M: ##integer>bignum generate-insn dst/src/temp %integer>bignum ;
M: ##bignum>integer generate-insn dst/src %bignum>integer ;
M: ##bignum>integer generate-insn dst/src/temp %bignum>integer ;
M: ##add-float generate-insn dst/src1/src2 %add-float ;
M: ##sub-float generate-insn dst/src1/src2 %sub-float ;

20
basis/compiler/tests/redefine12.factor Normal file
View File

@ -0,0 +1,20 @@
USING: kernel tools.test eval ;
IN: compiler.tests.redefine12
! A regression that came about when fixing the
! 'no method on classes-intersect?' bug
GENERIC: g ( a -- b )
M: object g drop t ;
: h ( a -- b ) dup [ g ] when ;
[ f ] [ f h ] unit-test
[ t ] [ "hi" h ] unit-test
TUPLE: jeah ;
[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval ] unit-test
[ f ] [ T{ jeah } h ] unit-test

2
basis/cpu/architecture/architecture.factor
View File

@ -76,7 +76,7 @@ HOOK: %sar-imm cpu ( dst src1 src2 -- )
HOOK: %not cpu ( dst src -- )
HOOK: %integer>bignum cpu ( dst src temp -- )
HOOK: %bignum>integer cpu ( dst src -- )
HOOK: %bignum>integer cpu ( dst src temp -- )
HOOK: %add-float cpu ( dst src1 src2 -- )
HOOK: %sub-float cpu ( dst src1 src2 -- )

112
basis/cpu/ppc/allot/allot.factor
View File

@ -1,112 +0,0 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cpu.ppc.architecture cpu.ppc.assembler
kernel.private namespaces math sequences generic arrays
compiler.generator compiler.generator.registers
compiler.generator.fixup system layouts
cpu.architecture alien ;
IN: cpu.ppc.allot
: load-zone-ptr ( reg -- )
>r "nursery" f r> %load-dlsym ;
: %allot ( header size -- )
#! Store a pointer to 'size' bytes allocated from the
#! nursery in r11.
8 align ! align the size
12 load-zone-ptr ! nusery -> r12
11 12 cell LWZ ! nursery.here -> r11
11 11 pick ADDI ! increment r11
11 12 cell STW ! r11 -> nursery.here
11 11 rot SUBI ! old value
type-number tag-fixnum 12 LI ! compute header
12 11 0 STW ! store header
;
: %store-tagged ( reg tag -- )
>r dup fresh-object v>operand 11 r> tag-number ORI ;
M: ppc %gc
"end" define-label
12 load-zone-ptr
11 12 cell LWZ ! nursery.here -> r11
12 12 3 cells LWZ ! nursery.end -> r12
11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
11 0 12 CMP ! is here >= end?
"end" get BLE
0 frame-required
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
: %allot-float ( reg -- )
#! exits with tagged ptr to object in r12, untagged in r11
float 16 %allot
11 8 STFD
12 11 float tag-number ORI
f fresh-object ;
M: ppc %box-float ( dst src -- )
[ v>operand ] bi@ %allot-float 12 MR ;
: %allot-bignum ( #digits -- )
#! 1 cell header, 1 cell length, 1 cell sign, + digits
#! length is the # of digits + sign
bignum over 3 + cells %allot
1+ v>operand 12 LI ! compute the length
12 11 cell STW ! store the length
;
: %allot-bignum-signed-1 ( reg -- )
#! on entry, reg is a 30-bit quantity sign-extended to
#! 32-bits.
#! exits with tagged ptr to bignum in reg
[
{ "end" "non-zero" "pos" "store" } [ define-label ] each
! is it zero?
0 over v>operand 0 CMPI
"non-zero" get BNE
dup 0 >bignum %load-literal
"end" get B
! it is non-zero
"non-zero" resolve-label
1 %allot-bignum
! is the fixnum negative?
0 over v>operand 0 CMPI
"pos" get BGE
1 12 LI
! store negative sign
12 11 2 cells STW
! negate fixnum
dup v>operand dup -1 MULI
"store" get B
"pos" resolve-label
0 12 LI
! store positive sign
12 11 2 cells STW
"store" resolve-label
! store the number
dup v>operand 11 3 cells STW
! tag the bignum, store it in reg
bignum %store-tagged
"end" resolve-label
] with-scope ;
M: ppc %box-alien ( dst src -- )
{ "end" "f" } [ define-label ] each
0 over v>operand 0 CMPI
"f" get BEQ
alien 4 cells %allot
! Store offset
v>operand 11 3 cells STW
f v>operand 12 LI
! Store expired slot
12 11 1 cells STW
! Store underlying-alien slot
12 11 2 cells STW
! Store tagged ptr in reg
dup object %store-tagged
"end" get B
"f" resolve-label
f v>operand swap v>operand LI
"end" resolve-label ;

1
basis/cpu/ppc/allot/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

1
basis/cpu/ppc/allot/summary.txt
View File

@ -1 +0,0 @@
PowerPC inline memory allocation

1
basis/cpu/ppc/allot/tags.txt
View File

@ -1 +0,0 @@
unportable

331
basis/cpu/ppc/architecture/architecture.factor
View File

@ -1,331 +0,0 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types cpu.ppc.assembler
cpu.architecture generic kernel kernel.private math memory
namespaces sequences words assocs compiler.generator
compiler.generator.registers compiler.generator.fixup system
layouts classes words.private alien combinators
compiler.constants math.order make ;
IN: cpu.ppc.architecture
! PowerPC register assignments
! r3-r10, r16-r31: integer vregs
! f0-f13: float vregs
! r11, r12: scratch
! r14: data stack
! r15: retain stack
: ds-reg 14 ; inline
: rs-reg 15 ; inline
: reserved-area-size ( -- n )
os {
{ linux [ 2 ] }
{ macosx [ 6 ] }
} case cells ; foldable
: lr-save ( -- n )
os {
{ linux [ 1 ] }
{ macosx [ 2 ] }
} case cells ; foldable
: param@ ( n -- x ) reserved-area-size + ; inline
: param-save-size ( -- n ) 8 cells ; foldable
: local@ ( n -- x )
reserved-area-size param-save-size + + ; inline
: factor-area-size ( -- n ) 2 cells ; foldable
: next-save ( n -- i ) cell - ;
: xt-save ( n -- i ) 2 cells - ;
M: ppc stack-frame-size ( n -- i )
local@ factor-area-size + 4 cells align ;
M: temp-reg v>operand drop 11 ;
M: int-regs return-reg drop 3 ;
M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ;
M: int-regs vregs
drop {
3 4 5 6 7 8 9 10
16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31
} ;
M: float-regs return-reg drop 1 ;
M: float-regs param-regs
drop os H{
{ macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
{ linux { 1 2 3 4 5 6 7 8 } }
} at ;
M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
GENERIC: loc>operand ( loc -- reg n )
M: ds-loc loc>operand n>> cells neg ds-reg swap ;
M: rs-loc loc>operand n>> cells neg rs-reg swap ;
M: immediate load-literal
[ v>operand ] bi@ LOAD ;
M: ppc load-indirect ( obj reg -- )
[ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
dup 0 LWZ ;
M: ppc %save-word-xt ( -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ;
M: ppc %prologue ( n -- )
0 MFLR
1 1 pick neg ADDI
11 1 pick xt-save STW
dup 11 LI
11 1 pick next-save STW
0 1 rot lr-save + STW ;
M: ppc %epilogue ( n -- )
#! 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 pick lr-save + LWZ
1 1 rot ADDI
0 MTLR ;
: (%call) ( reg -- ) MTLR BLRL ;
: (%jump) ( reg -- ) MTCTR BCTR ;
: %load-dlsym ( symbol dll register -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
M: ppc %call ( label -- ) BL ;
M: ppc %jump-label ( label -- ) B ;
M: ppc %jump-f ( label -- )
0 "flag" operand f v>operand CMPI BEQ ;
M: ppc %dispatch ( -- )
[
%epilogue-later
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
"offset" operand "n" operand 1 SRAWI
11 11 "offset" operand ADD
11 dup 6 cells LWZ
11 (%jump)
] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
} with-template ;
M: ppc %dispatch-label ( word -- )
0 , rc-absolute-cell rel-word ;
M: ppc %return ( -- ) %epilogue-later BLR ;
M: ppc %peek ( vreg loc -- )
>r v>operand r> loc>operand LWZ ;
M: ppc %replace
>r v>operand r> loc>operand STW ;
M: ppc %unbox-float ( dst src -- )
[ v>operand ] bi@ float-offset LFD ;
M: ppc %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
M: ppc %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
M: int-regs %save-param-reg drop 1 rot local@ STW ;
M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
GENERIC: STF ( src dst off reg-class -- )
M: single-float-regs STF drop STFS ;
M: double-float-regs STF drop STFD ;
M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
GENERIC: LF ( dst src off reg-class -- )
M: single-float-regs LF drop LFS ;
M: double-float-regs LF drop LFD ;
M: float-regs %load-param-reg >r 1 rot local@ r> LF ;
M: stack-params %load-param-reg ( stack reg reg-class -- )
drop >r 0 1 rot local@ LWZ 0 1 r> param@ STW ;
: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
M: stack-params %save-param-reg ( stack reg reg-class -- )
#! Funky. Read the parameter from the caller's stack frame.
#! This word is used in callbacks
drop
0 1 rot next-param@ LWZ
0 1 rot local@ STW ;
M: ppc %prepare-unbox ( -- )
! First parameter is top of stack
3 ds-reg 0 LWZ
ds-reg dup cell SUBI ;
M: ppc %unbox ( n reg-class func -- )
! Value must be in r3
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
M: ppc %unbox-long-long ( n func -- )
! Value must be in r3:r4
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
[
3 1 pick local@ STW
4 1 rot cell + local@ STW
] when* ;
M: ppc %unbox-large-struct ( n c-type -- )
! Value must be in r3
! Compute destination address and load struct size
[ 4 1 rot local@ ADDI ] [ heap-size 5 LI ] bi*
! Call the function
"to_value_struct" f %alien-invoke ;
M: ppc %box ( n reg-class func -- )
! If the source is a stack location, load it into freg #0.
! If the source is f, then we assume the value is already in
! freg #0.
>r
over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
r> f %alien-invoke ;
M: ppc %box-long-long ( n func -- )
>r [
3 1 pick local@ LWZ
4 1 rot cell + local@ LWZ
] when* r> f %alien-invoke ;
: struct-return@ ( n -- n )
[ stack-frame get params>> ] unless* local@ ;
M: ppc %prepare-box-struct ( -- )
#! Compute target address for value struct return
3 1 f struct-return@ ADDI
3 1 0 local@ STW ;
M: ppc %box-large-struct ( n c-type -- )
! If n = f, then we're boxing a returned struct
! Compute destination address and load struct size
[ 3 1 rot struct-return@ ADDI ] [ heap-size 4 LI ] bi*
! Call the function
"box_value_struct" f %alien-invoke ;
M: ppc %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
"stack_chain" f 11 %load-dlsym
11 11 0 LWZ
1 11 0 STW
ds-reg 11 8 STW
rs-reg 11 12 STW ;
M: ppc %alien-invoke ( symbol dll -- )
11 %load-dlsym 11 (%call) ;
M: ppc %alien-callback ( quot -- )
3 load-indirect "c_to_factor" f %alien-invoke ;
M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
13 3 MR ;
M: ppc %alien-indirect ( -- )
13 (%call) ;
M: ppc %callback-value ( ctype -- )
! Save top of data stack
3 ds-reg 0 LWZ
3 1 0 local@ STW
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
! Restore top of data stack
3 1 0 local@ LWZ
! Unbox former top of data stack to return registers
unbox-return ;
: %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ;
: %tag-fixnum ( src dest -- ) tag-bits get SLWI ;
: %untag-fixnum ( dest src -- ) tag-bits get SRAWI ;
M: ppc value-structs?
#! On Linux/PPC, value structs are passed in the same way
#! as reference structs, we just have to make a copy first.
os linux? not ;
M: ppc fp-shadows-int? ( -- ? ) os macosx? ;
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
M: ppc struct-small-enough? ( size -- ? ) drop f ;
M: ppc %box-small-struct
drop "No small structs" throw ;
M: ppc %unbox-small-struct
drop "No small structs" throw ;
! Alien intrinsics
M: ppc %unbox-byte-array ( dst src -- )
[ v>operand ] bi@ byte-array-offset ADDI ;
M: ppc %unbox-alien ( dst src -- )
[ v>operand ] bi@ alien-offset LWZ ;
M: ppc %unbox-f ( dst src -- )
drop 0 swap v>operand LI ;
M: ppc %unbox-any-c-ptr ( dst src -- )
{ "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in R12
0 12 LI
! Load object into R11
11 swap v>operand MR
! We come back here with displaced aliens
"start" resolve-label
! Is the object f?
0 11 f v>operand CMPI
! If so, done
"end" get BEQ
! Is the object an alien?
0 11 header-offset LWZ
0 0 alien type-number tag-fixnum CMPI
"is-byte-array" get BNE
! If so, load the offset
0 11 alien-offset LWZ
! Add it to address being computed
12 12 0 ADD
! Now recurse on the underlying alien
11 11 underlying-alien-offset LWZ
"start" get B
"is-byte-array" resolve-label
! Add byte array address to address being computed
12 12 11 ADD
! Add an offset to start of byte array's data area
12 12 byte-array-offset ADDI
"end" resolve-label
! Done, store address in destination register
v>operand 12 MR ;

1
basis/cpu/ppc/architecture/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

1
basis/cpu/ppc/architecture/summary.txt
View File

@ -1 +0,0 @@
PowerPC architecture description

1
basis/cpu/ppc/architecture/tags.txt
View File

@ -1 +0,0 @@
unportable

4
basis/cpu/ppc/bootstrap.factor
View File

@ -11,8 +11,8 @@ big-endian on
4 jit-code-format set
: ds-reg 14 ;
: rs-reg 15 ;
: ds-reg 30 ;
: rs-reg 31 ;
: factor-area-size ( -- n ) 4 bootstrap-cells ;

1
basis/cpu/ppc/intrinsics/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

640
basis/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -1,640 +0,0 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.accessors alien.c-types arrays
cpu.ppc.assembler cpu.ppc.architecture cpu.ppc.allot
cpu.architecture kernel kernel.private math math.private
namespaces sequences words generic quotations byte-arrays
hashtables hashtables.private
sequences.private sbufs vectors system layouts
math.floats.private classes slots.private
combinators
compiler.constants
compiler.intrinsics
compiler.generator
compiler.generator.fixup
compiler.generator.registers ;
IN: cpu.ppc.intrinsics
: %slot-literal-known-tag ( -- out value offset )
"val" operand
"obj" operand
"n" get cells
"obj" get operand-tag - ;
: %slot-literal-any-tag ( -- out value offset )
"obj" operand "scratch1" operand %untag
"val" operand "scratch1" operand "n" get cells ;
: %slot-any ( -- out value offset )
"obj" operand "scratch1" operand %untag
"offset" operand "n" operand 1 SRAWI
"scratch1" operand "val" operand "offset" operand ;
\ slot {
! Slot number is literal and the tag is known
{
[ %slot-literal-known-tag LWZ ] H{
{ +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
{ +scratch+ { { f "val" } } }
{ +output+ { "val" } }
}
}
! Slot number is literal
{
[ %slot-literal-any-tag LWZ ] H{
{ +input+ { { f "obj" } { [ small-slot? ] "n" } } }
{ +scratch+ { { f "scratch1" } { f "val" } } }
{ +output+ { "val" } }
}
}
! Slot number in a register
{
[ %slot-any LWZX ] H{
{ +input+ { { f "obj" } { f "n" } } }
{ +scratch+ { { f "val" } { f "scratch1" } { f "offset" } } }
{ +output+ { "val" } }
}
}
} define-intrinsics
: load-cards-offset ( dest -- )
"cards_offset" f pick %load-dlsym dup 0 LWZ ;
: load-decks-offset ( dest -- )
"decks_offset" f pick %load-dlsym dup 0 LWZ ;
: %write-barrier ( -- )
"val" get operand-immediate? "obj" get fresh-object? or [
card-mark "scratch1" operand LI
! Mark the card
"val" operand load-cards-offset
"obj" operand "scratch2" operand card-bits SRWI
"scratch2" operand "scratch1" operand "val" operand STBX
! Mark the card deck
"val" operand load-decks-offset
"obj" operand "scratch2" operand deck-bits SRWI
"scratch2" operand "scratch1" operand "val" operand STBX
] unless ;
\ set-slot {
! Slot number is literal and tag is known
{
[ %slot-literal-known-tag STW %write-barrier ] H{
{ +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
{ +scratch+ { { f "scratch1" } { f "scratch2" } } }
{ +clobber+ { "val" } }
}
}
! Slot number is literal
{
[ %slot-literal-any-tag STW %write-barrier ] H{
{ +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
{ +scratch+ { { f "scratch1" } { f "scratch2" } } }
{ +clobber+ { "val" } }
}
}
! Slot number is in a register
{
[ %slot-any STWX %write-barrier ] H{
{ +input+ { { f "val" } { f "obj" } { f "n" } } }
{ +scratch+ { { f "scratch1" } { f "scratch2" } { f "offset" } } }
{ +clobber+ { "val" } }
}
}
} define-intrinsics
: fixnum-register-op ( op -- pair )
[ "out" operand "y" operand "x" operand ] swap suffix H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} 2array ;
: fixnum-value-op ( op -- pair )
[ "out" operand "x" operand "y" operand ] swap suffix H{
{ +input+ { { f "x" } { [ small-tagged? ] "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} 2array ;
: define-fixnum-op ( word imm-op reg-op -- )
>r fixnum-value-op r> fixnum-register-op 2array
define-intrinsics ;
{
{ fixnum+fast ADDI ADD }
{ fixnum-fast SUBI SUBF }
{ fixnum-bitand ANDI AND }
{ fixnum-bitor ORI OR }
{ fixnum-bitxor XORI XOR }
} [
first3 define-fixnum-op
] each
\ fixnum*fast {
{
[
"out" operand "x" operand "y" get MULLI
] H{
{ +input+ { { f "x" } { [ small-tagged? ] "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
}
} {
[
"out" operand "x" operand %untag-fixnum
"out" operand "y" operand "out" operand MULLW
] H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
}
}
} define-intrinsics
: %untag-fixnums ( seq -- )
[ dup %untag-fixnum ] unique-operands ;
\ fixnum-shift-fast {
{
[
"out" operand "x" operand "y" get
dup 0 < [ neg SRAWI ] [ swapd SLWI ] if
! Mask off low bits
"out" operand dup %untag
] H{
{ +input+ { { f "x" } { [ ] "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
}
}
{
[
{ "positive" "end" } [ define-label ] each
"out" operand "y" operand %untag-fixnum
0 "y" operand 0 CMPI
"positive" get BGE
"out" operand dup NEG
"out" operand "x" operand "out" operand SRAW
"end" get B
"positive" resolve-label
"out" operand "x" operand "out" operand SLW
"end" resolve-label
! Mask off low bits
"out" operand dup %untag
] H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
}
}
} define-intrinsics
: generate-fixnum-mod ( -- )
#! PowerPC doesn't have a MOD instruction; so we compute
#! x-(x/y)*y. Puts the result in "s" operand.
"s" operand "r" operand "y" operand MULLW
"s" operand "s" operand "x" operand SUBF ;
\ fixnum-mod [
! divide x by y, store result in x
"r" operand "x" operand "y" operand DIVW
generate-fixnum-mod
] H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "r" } { f "s" } } }
{ +output+ { "s" } }
} define-intrinsic
\ fixnum-bitnot [
"x" operand dup NOT
"x" operand dup %untag
] H{
{ +input+ { { f "x" } } }
{ +output+ { "x" } }
} define-intrinsic
: fixnum-register-jump ( op -- pair )
[ "x" operand 0 "y" operand CMP ] swap suffix
{ { f "x" } { f "y" } } 2array ;
: fixnum-value-jump ( op -- pair )
[ 0 "x" operand "y" operand CMPI ] swap suffix
{ { f "x" } { [ small-tagged? ] "y" } } 2array ;
: define-fixnum-jump ( word op -- )
[ fixnum-value-jump ] keep fixnum-register-jump
2array define-if-intrinsics ;
{
{ fixnum< BGE }
{ fixnum<= BGT }
{ fixnum> BLE }
{ fixnum>= BLT }
{ eq? BNE }
} [
first2 define-fixnum-jump
] each
: overflow-check ( insn1 insn2 -- )
[
>r 0 0 LI
0 MTXER
"r" operand "y" operand "x" operand r> execute
>r
"end" define-label
"end" get BNO
{ "x" "y" } %untag-fixnums
"r" operand "y" operand "x" operand r> execute
"r" get %allot-bignum-signed-1
"end" resolve-label
] with-scope ; inline
: overflow-template ( word insn1 insn2 -- )
[ overflow-check ] 2curry H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "r" } } }
{ +output+ { "r" } }
{ +clobber+ { "x" "y" } }
} define-intrinsic ;
\ fixnum+ \ ADD \ ADDO. overflow-template
\ fixnum- \ SUBF \ SUBFO. overflow-template
: generate-fixnum/i ( -- )
#! This VOP is funny. If there is an overflow, it falls
#! through to the end, and the result is in "x" operand.
#! Otherwise it jumps to the "no-overflow" label and the
#! result is in "r" operand.
"end" define-label
"no-overflow" define-label
"r" operand "x" operand "y" operand DIVW
! if the result is greater than the most positive fixnum,
! which can only ever happen if we do
! most-negative-fixnum -1 /i, then the result is a bignum.
most-positive-fixnum "s" operand LOAD
"r" operand 0 "s" operand CMP
"no-overflow" get BLE
most-negative-fixnum neg "x" operand LOAD
"x" get %allot-bignum-signed-1 ;
\ fixnum/i [
generate-fixnum/i
"end" get B
"no-overflow" resolve-label
"r" operand "x" operand %tag-fixnum
"end" resolve-label
] H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "r" } { f "s" } } }
{ +output+ { "x" } }
{ +clobber+ { "y" } }
} define-intrinsic
\ fixnum/mod [
generate-fixnum/i
0 "s" operand LI
"end" get B
"no-overflow" resolve-label
generate-fixnum-mod
"r" operand "x" operand %tag-fixnum
"end" resolve-label
] H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "r" } { f "s" } } }
{ +output+ { "x" "s" } }
{ +clobber+ { "y" } }
} define-intrinsic
\ fixnum>bignum [
"x" operand dup %untag-fixnum
"x" get %allot-bignum-signed-1
] H{
{ +input+ { { f "x" } } }
{ +output+ { "x" } }
} define-intrinsic
\ bignum>fixnum [
"nonzero" define-label
"positive" define-label
"end" define-label
"x" operand dup %untag
"y" operand "x" operand cell LWZ
! if the length is 1, its just the sign and nothing else,
! so output 0
0 "y" operand 1 v>operand CMPI
"nonzero" get BNE
0 "y" operand LI
"end" get B
"nonzero" resolve-label
! load the value
"y" operand "x" operand 3 cells LWZ
! load the sign
"x" operand "x" operand 2 cells LWZ
! is the sign negative?
0 "x" operand 0 CMPI
"positive" get BEQ
"y" operand dup -1 MULI
"positive" resolve-label
"y" operand dup %tag-fixnum
"end" resolve-label
] H{
{ +input+ { { f "x" } } }
{ +scratch+ { { f "y" } } }
{ +clobber+ { "x" } }
{ +output+ { "y" } }
} define-intrinsic
: define-float-op ( word op -- )
[ "z" operand "x" operand "y" operand ] swap suffix H{
{ +input+ { { float "x" } { float "y" } } }
{ +scratch+ { { float "z" } } }
{ +output+ { "z" } }
} define-intrinsic ;
{
{ float+ FADD }
{ float- FSUB }
{ float* FMUL }
{ float/f FDIV }
} [
first2 define-float-op
] each
: define-float-jump ( word op -- )
[ "x" operand 0 "y" operand FCMPU ] swap suffix
{ { float "x" } { float "y" } } define-if-intrinsic ;
{
{ float< BGE }
{ float<= BGT }
{ float> BLE }
{ float>= BLT }
{ float= BNE }
} [
first2 define-float-jump
] each
\ float>fixnum [
"scratch" operand "in" operand FCTIWZ
"scratch" operand 1 0 param@ STFD
"out" operand 1 cell param@ LWZ
"out" operand dup %tag-fixnum
] H{
{ +input+ { { float "in" } } }
{ +scratch+ { { float "scratch" } { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ fixnum>float [
HEX: 4330 "scratch" operand LIS
"scratch" operand 1 0 param@ STW
"scratch" operand "in" operand %untag-fixnum
"scratch" operand dup HEX: 8000 XORIS
"scratch" operand 1 cell param@ STW
"f1" operand 1 0 param@ LFD
4503601774854144.0 "scratch" operand load-indirect
"f2" operand "scratch" operand float-offset LFD
"f1" operand "f1" operand "f2" operand FSUB
] H{
{ +input+ { { f "in" } } }
{ +scratch+ { { f "scratch" } { float "f1" } { float "f2" } } }
{ +output+ { "f1" } }
} define-intrinsic
\ tag [
"out" operand "in" operand tag-mask get ANDI
"out" operand dup %tag-fixnum
] H{
{ +input+ { { f "in" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
: userenv ( reg -- )
#! Load the userenv pointer in a register.
"userenv" f rot %load-dlsym ;
\ getenv [
"n" operand dup 1 SRAWI
"x" operand userenv
"x" operand "n" operand "x" operand ADD
"x" operand dup 0 LWZ
] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "x" } } }
{ +output+ { "x" } }
{ +clobber+ { "n" } }
} define-intrinsic
\ setenv [
"n" operand dup 1 SRAWI
"x" operand userenv
"x" operand "n" operand "x" operand ADD
"val" operand "x" operand 0 STW
] H{
{ +input+ { { f "val" } { f "n" } } }
{ +scratch+ { { f "x" } } }
{ +clobber+ { "n" } }
} define-intrinsic
\ (tuple) [
tuple "layout" get size>> 2 + cells %allot
! Store layout
"layout" get 12 load-indirect
12 11 cell STW
! Store tagged ptr in reg
"tuple" get tuple %store-tagged
] H{
{ +input+ { { [ ] "layout" } } }
{ +scratch+ { { f "tuple" } } }
{ +output+ { "tuple" } }
} define-intrinsic
\ (array) [
array "n" get 2 + cells %allot
! Store length
"n" operand 12 LI
12 11 cell STW
! Store tagged ptr in reg
"array" get object %store-tagged
] H{
{ +input+ { { [ ] "n" } } }
{ +scratch+ { { f "array" } } }
{ +output+ { "array" } }
} define-intrinsic
\ (byte-array) [
byte-array "n" get 2 cells + %allot
! Store length
"n" operand 12 LI
12 11 cell STW
! Store tagged ptr in reg
"array" get object %store-tagged
] H{
{ +input+ { { [ ] "n" } } }
{ +scratch+ { { f "array" } } }
{ +output+ { "array" } }
} define-intrinsic
\ <ratio> [
ratio 3 cells %allot
"numerator" operand 11 1 cells STW
"denominator" operand 11 2 cells STW
! Store tagged ptr in reg
"ratio" get ratio %store-tagged
] H{
{ +input+ { { f "numerator" } { f "denominator" } } }
{ +scratch+ { { f "ratio" } } }
{ +output+ { "ratio" } }
} define-intrinsic
\ <complex> [
complex 3 cells %allot
"real" operand 11 1 cells STW
"imaginary" operand 11 2 cells STW
! Store tagged ptr in reg
"complex" get complex %store-tagged
] H{
{ +input+ { { f "real" } { f "imaginary" } } }
{ +scratch+ { { f "complex" } } }
{ +output+ { "complex" } }
} define-intrinsic
\ <wrapper> [
wrapper 2 cells %allot
"obj" operand 11 1 cells STW
! Store tagged ptr in reg
"wrapper" get object %store-tagged
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "wrapper" } } }
{ +output+ { "wrapper" } }
} define-intrinsic
! Alien intrinsics
: %alien-accessor ( quot -- )
"offset" operand dup %untag-fixnum
"scratch" operand "offset" operand "alien" operand ADD
"value" operand "scratch" operand 0 roll call ; inline
: alien-integer-get-template
H{
{ +input+ {
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "value" } { f "scratch" } } }
{ +output+ { "value" } }
{ +clobber+ { "offset" } }
} ;
: %alien-integer-get ( quot -- )
%alien-accessor
"value" operand dup %tag-fixnum ; inline
: alien-integer-set-template
H{
{ +input+ {
{ f "value" fixnum }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "value" "offset" } }
} ;
: %alien-integer-set ( quot -- )
"offset" get "value" get = [
"value" operand dup %untag-fixnum
] unless
%alien-accessor ; inline
: define-alien-integer-intrinsics ( word get-quot word set-quot -- )
[ %alien-integer-set ] curry
alien-integer-set-template
define-intrinsic
[ %alien-integer-get ] curry
alien-integer-get-template
define-intrinsic ;
\ alien-unsigned-1 [ LBZ ]
\ set-alien-unsigned-1 [ STB ]
define-alien-integer-intrinsics
\ alien-signed-1 [ pick >r LBZ r> dup EXTSB ]
\ set-alien-signed-1 [ STB ]
define-alien-integer-intrinsics
\ alien-unsigned-2 [ LHZ ]
\ set-alien-unsigned-2 [ STH ]
define-alien-integer-intrinsics
\ alien-signed-2 [ LHA ]
\ set-alien-signed-2 [ STH ]
define-alien-integer-intrinsics
\ alien-cell [
[ LWZ ] %alien-accessor
] H{
{ +input+ {
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { unboxed-alien "value" } { f "scratch" } } }
{ +output+ { "value" } }
{ +clobber+ { "offset" } }
} define-intrinsic
\ set-alien-cell [
[ STW ] %alien-accessor
] H{
{ +input+ {
{ unboxed-c-ptr "value" pinned-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "offset" } }
} define-intrinsic
: alien-float-get-template
H{
{ +input+ {
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { float "value" } { f "scratch" } } }
{ +output+ { "value" } }
{ +clobber+ { "offset" } }
} ;
: alien-float-set-template
H{
{ +input+ {
{ float "value" float }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "offset" } }
} ;
: define-alien-float-intrinsics ( word get-quot word set-quot -- )
[ %alien-accessor ] curry
alien-float-set-template
define-intrinsic
[ %alien-accessor ] curry
alien-float-get-template
define-intrinsic ;
\ alien-double [ LFD ]
\ set-alien-double [ STFD ]
define-alien-float-intrinsics
\ alien-float [ LFS ]
\ set-alien-float [ STFS ]
define-alien-float-intrinsics

1
basis/cpu/ppc/intrinsics/tags.txt
View File

@ -1 +0,0 @@
unportable

593
basis/cpu/ppc/ppc.factor
View File

@ -1,8 +1,32 @@
USING: accessors cpu.ppc.architecture cpu.ppc.intrinsics
cpu.architecture namespaces alien.c-types kernel system
combinators ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types
accessors
cpu.architecture
compiler.cfg.registers
cpu.ppc.assembler
kernel
locals
layouts
combinators
make
compiler.cfg.instructions
math.order
system
math
compiler.constants
namespaces compiler.codegen.fixup ;
IN: cpu.ppc
{
! PowerPC register assignments:
! r2-r28: integer vregs
! r29: integer scratch
! r30: data stack
! r31: retain stack
! f0-f29: float vregs
! f30, f31: float scratch
<< {
{ [ os macosx? ] [
4 "longlong" c-type (>>align)
4 "ulonglong" c-type (>>align)
@ -12,4 +36,563 @@ combinators ;
t "longlong" c-type (>>stack-align?)
t "ulonglong" c-type (>>stack-align?)
] }
} cond
} cond >>
M: ppc machine-registers
{
{ int-regs T{ range f 2 27 1 } }
{ double-float-regs T{ range f 0 28 1 } }
} ;
: scratch-reg 29 ; inline
: fp-scratch-reg-1 30 ; inline
: fp-scratch-reg-2 31 ; inline
M: ppc two-operand? f ;
M: ppc %load-immediate ( reg n -- ) swap LOAD ;
M:: ppc %load-indirect ( reg obj -- )
0 reg LOAD32
obj rc-absolute-ppc-2/2 rel-literal
reg reg 0 LWZ ;
: ds-reg 30 ; inline
: rs-reg 31 ; inline
GENERIC: loc-reg ( loc -- reg )
M: ds-loc log-reg drop ds-reg ;
M: rs-loc log-reg drop rs-reg ;
: loc>operand ( loc -- reg n )
[ loc-reg ] [ n>> cells neg ] bi ; inline
M: ppc %peek loc>operand LWZ ;
M: ppc %replace loc>operand STW ;
: (%inc) ( n reg -- ) dup rot cells ADDI ; inline
M: ppc %inc-d ( n -- ) ds-reg (%inc) ;
M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
: reserved-area-size ( -- n )
os {
{ linux [ 2 ] }
{ macosx [ 6 ] }
} case cells ; foldable
: lr-save ( -- n )
os {
{ linux [ 1 ] }
{ macosx [ 2 ] }
} case cells ; foldable
: param@ ( n -- x ) reserved-area-size + ; inline
: param-save-size ( -- n ) 8 cells ; foldable
: local@ ( n -- x )
reserved-area-size param-save-size + + ; inline
: factor-area-size ( -- n ) 2 cells ; foldable
: next-save ( n -- i ) cell - ;
: xt-save ( n -- i ) 2 cells - ;
M: ppc stack-frame-size ( stack-frame -- i )
[ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
[ params>> ]
[ return>> ]
tri + +
reserved-area-size +
param-save-size +
factor-area-size +
4 cells align ;
M: ppc %call ( label -- ) BL ;
M: ppc %jump-label ( label -- ) B ;
M: ppc %return ( -- ) BLR ;
M:: ppc %dispatch ( src temp -- )
0 temp LOAD32 rc-absolute-ppc-2/2 rel-here
temp temp src ADD
temp temp 5 cells LWZ
temp MTCTR
BCTR ;
M: ppc %dispatch-label ( word -- )
0 , rc-absolute-cell rel-word ;
:: (%slot) ( obj slot tag temp -- reg offset )
temp slot obj ADD
temp tag neg ; inline
: (%slot-imm) ( obj slot tag -- reg offset )
[ cells ] dip - ; inline
M: ppc %slot ( dst obj slot tag temp -- ) (%slot) LWZ ;
M: ppc %slot-imm ( dst obj slot tag -- ) (%slot-imm) LWZ ;
M: ppc %set-slot ( src obj slot tag temp -- ) (%slot) STW ;
M: ppc %set-slot-imm ( src obj slot tag -- ) (%slot-imm) STW ;
M: ppc %add ADD ;
M: ppc %add-imm ADDI ;
M: ppc %sub swapd SUBF ;
M: ppc %sub-imm SUBI ;
M: ppc %mul MULLW ;
M: ppc %mul-imm MULLI ;
M: ppc %and AND ;
M: ppc %and-imm ANDI ;
M: ppc %or OR ;
M: ppc %or-imm ORI ;
M: ppc %xor XOR ;
M: ppc %xor-imm XORI ;
M: ppc %shl-imm swapd SLWI ;
M: ppc %shr-imm swapd SRWI ;
M: ppc %sar-imm SRAWI ;
M: ppc %not NOT ;
: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
M: ppc %integer>bignum ( dst src temp -- )
[
{ "end" "non-zero" "pos" "store" } [ define-label ] each
dst 0 >bignum %load-immediate
! Is it zero? Then just go to the end and return this zero
0 src 0 CMPI
"end" get BEQ
! Allocate a bignum
dst 4 cells bignum temp %allot
! Write length
2 temp LI
dst 1 bignum@ temp STW
! Store value
dst 3 bignum@ src STW
! Compute sign
temp src MR
temp cell-bits 1- SRAWI
temp temp 1 ANDI
! Store sign
dst 2 bignum@ temp STW
! Make negative value positive
temp temp temp ADD
temp temp NEG
temp temp 1 ADDI
temp src temp MULLW
! Store the bignum
dst 3 bignum@ temp STW
"end" resolve-label
] with-scope ;
M:: %bignum>integer ( dst src temp -- )
[
"end" define-label
temp src 1 bignum@ LWZ
! if the length is 1, its just the sign and nothing else,
! so output 0
0 dst LI
0 temp 1 v>operand CMPI
"end" get BEQ
! load the value
dst src 3 bignum@ LWZ
! load the sign
temp src 2 bignum@ LWZ
! branchless arithmetic: we want to turn 0 into 1,
! and 1 into -1
temp temp temp ADD
temp temp 1 SUBI
! multiply value by sign
dst dst temp MULLW
"end" resolve-label
] with-scope ;
M: ppc %add-float FADD ;
M: ppc %sub-float FSUB ;
M: ppc %mul-float FMUL ;
M: ppc %div-float FDIV ;
M: ppc %integer>float ( dst src -- )
HEX: 4330 scratch-reg LIS
scratch-reg 1 0 param@ STW
scratch-reg src MR
scratch-reg dup HEX: 8000 XORIS
scratch-reg 1 cell param@ STW
fp-scratch-reg-2 1 0 param@ LFD
4503601774854144.0 scratch-reg load-indirect
fp-scratch-reg-2 scratch-reg float-offset LFD
fp-scratch-reg-2 fp-scratch-reg-2 fp-scratch-reg-2 FSUB ;
M:: ppc %float>integer ( dst src -- )
fp-scratch-reg-1 src FCTIWZ
fp-scratch-reg-2 1 0 param@ STFD
dst 1 4 param@ LWZ ;
M: ppc %copy ( dst src -- ) MR ;
M: ppc %copy-float ( dst src -- ) MFR ;
M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
M:: ppc %unbox-any-c-ptr ( dst src temp -- )
[
{ "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in dst
0 dst LI
! Load object into scratch-reg
scratch-reg src MR
! We come back here with displaced aliens
"start" resolve-label
! Is the object f?
0 scratch-reg \ f tag-number CMPI
! If so, done
"end" get BEQ
! Is the object an alien?
0 scratch-reg header-offset LWZ
0 0 alien type-number tag-fixnum CMPI
"is-byte-array" get BNE
! If so, load the offset
0 scratch-reg alien-offset LWZ
! Add it to address being computed
dst dst 0 ADD
! Now recurse on the underlying alien
scratch-reg scratch-reg underlying-alien-offset LWZ
"start" get B
"is-byte-array" resolve-label
! Add byte array address to address being computed
dst dst scratch-reg ADD
! Add an offset to start of byte array's data area
dst dst byte-array-offset ADDI
"end" resolve-label
] with-scope ;
: alien@ ( n -- n' ) cells object tag-number - ;
M:: ppc %box-alien ( dst src temp -- )
[
"f" define-label
dst \ f tag-number %load-immediate
0 src 0 CMPI
"f" get BEQ
dst 4 cells alien temp %allot
! Store offset
dst src 3 alien@ STW
temp \ f tag-number %load-immediate
! Store expired slot
temp dst 1 alien@ STW
! Store underlying-alien slot
temp dst 2 alien@ STW
"f" resolve-label
] with-scope ;
M: ppc %alien-unsigned-1 0 LBZ ;
M: ppc %alien-unsigned-2 0 LHZ ;
M: ppc %alien-signed-1 dupd 0 LBZ EXTSB ;
M: ppc %alien-signed-2 0 LHA ;
M: ppc %alien-cell 0 LWZ ;
M: ppc %alien-float 0 LFS ;
M: ppc %alien-double 0 LFD ;
M: ppc %set-alien-integer-1 0 STB ;
M: ppc %set-alien-integer-2 0 STH ;
M: ppc %set-alien-cell 0 STW ;
M: ppc %set-alien-float 0 STFS ;
M: ppc %set-alien-double 0 STFD ;
: load-zone-ptr ( reg -- )
[ "nursery" f ] dip %load-dlsym ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop load-zone-ptr ] [ swap cell LWZ ] 2bi ;
:: inc-allot-ptr ( nursery-ptr n -- )
scratch-reg inc-allot-ptr 4 LWZ
scratch-reg scratch-reg n 8 align ADD
scratch-reg inc-allot-ptr 4 STW ;
:: store-header ( temp class -- )
class type-number tag-fixnum scratch-reg LI
temp scratch-reg 0 STW ;
: store-tagged ( dst tag -- )
dupd tag-number ORI ;
M:: ppc %allot ( dst size class nursery-ptr -- )
nursery-ptr dst load-allot-ptr
dst class store-header
dst class store-tagged
nursery-ptr size inc-allot-ptr ;
: %alien-global ( dest name -- )
[ f swap %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
: load-cards-offset ( dest -- )
"cards_offset" %alien-global ;
: load-decks-offset ( dest -- )
"decks_offset" %alien-global ;
M:: ppc %write-barrier ( src card# table -- )
card-mark scratch-reg LI
! Mark the card
table load-cards-offset
src card# card-bits SRWI
table scratch-reg card# STBX
! Mark the card deck
table load-decks-offset
src card# deck-bits SRWI
table scratch-reg card# STBX ;
M: ppc %gc
"end" define-label
12 load-zone-ptr
11 12 cell LWZ ! nursery.here -> r11
12 12 3 cells LWZ ! nursery.end -> r12
11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
11 0 12 CMP ! is here >= end?
"end" get BLE
0 frame-required
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
M: ppc %prologue ( n -- )
0 scrach-reg LOAD32 rc-absolute-ppc-2/2 rel-this
0 MFLR
1 1 pick neg ADDI
scrach-reg 1 pick xt-save STW
dup scrach-reg LI
scrach-reg 1 pick next-save STW
0 1 rot lr-save + STW ;
M: ppc %epilogue ( n -- )
#! 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 pick lr-save + LWZ
1 1 rot ADDI
0 MTLR ;
:: (%boolean) ( dst word -- )
"end" define-label
\ f tag-number %load-immediate
"end" get word execute
dst \ t %load-indirect
"end" get resolve-label ; inline
: %boolean ( dst cc -- )
negate-cc {
{ cc< [ \ BLT %boolean ] }
{ cc<= [ \ BLE %boolean ] }
{ cc> [ \ BGT %boolean ] }
{ cc>= [ \ BGE %boolean ] }
{ cc= [ \ BEQ %boolean ] }
{ cc/= [ \ BNE %boolean ] }
} case ;
: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
: (%compare-imm) ( src1 src2 -- ) [ 0 ] 2dip CMPI ; inline
: (%compare-float) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
M: ppc %compare (%compare) %boolean ;
M: ppc %compare-imm (%compare-imm) %boolean ;
M: ppc %compare-float (%compare-float) %boolean ;
: %branch ( label cc -- )
{
{ cc< [ BLT ] }
{ cc<= [ BLE ] }
{ cc> [ BGT ] }
{ cc>= [ BGE ] }
{ cc= [ BEQ ] }
{ cc/= [ BNE ] }
} case ;
M: ppc %compare-branch (%compare) %branch ;
M: ppc %compare-imm-branch (%compare-imm) %branch ;
M: ppc %compare-float-branch (%compare-float) %branch ;
: spill-integer-base ( stack-frame -- n )
[ params>> ] [ return>> ] bi + ;
: stack@ 1 swap ; inline
: spill-integer@ ( n -- op )
cells
stack-frame get spill-integer-base
+ stack@ ;
: spill-float-base ( stack-frame -- n )
[ spill-counts>> int-regs swap at int-regs reg-size * ]
[ params>> ]
[ return>> ]
tri + + ;
: spill-float@ ( n -- op )
double-float-regs reg-size *
stack-frame get spill-float-base
+ stack@ ;
M: ppc %spill-integer ( src n -- ) spill-integer@ STW ;
M: ppc %reload-integer ( dst n -- ) spill-integer@ LWZ ;
M: ppc %spill-float ( src n -- ) spill-float@ STFD ;
M: ppc %reload-float ( dst n -- ) spill-float@ LFD ;
M: ppc %loop-entry ;
M: int-regs return-reg drop 3 ;
M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ;
M: float-regs return-reg drop 1 ;
M: float-regs param-regs
drop os H{
{ macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
{ linux { 1 2 3 4 5 6 7 8 } }
} at ;
M: int-regs %save-param-reg drop 1 rot local@ STW ;
M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
GENERIC: STF ( src dst off reg-class -- )
M: single-float-regs STF drop STFS ;
M: double-float-regs STF drop STFD ;
M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
GENERIC: LF ( dst src off reg-class -- )
M: single-float-regs LF drop LFS ;
M: double-float-regs LF drop LFD ;
M: float-regs %load-param-reg >r 1 rot local@ r> LF ;
M: stack-params %load-param-reg ( stack reg reg-class -- )
drop >r 0 1 rot local@ LWZ 0 1 r> param@ STW ;
: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
M: stack-params %save-param-reg ( stack reg reg-class -- )
#! Funky. Read the parameter from the caller's stack frame.
#! This word is used in callbacks
drop
0 1 rot next-param@ LWZ
0 1 rot local@ STW ;
M: ppc %prepare-unbox ( -- )
! First parameter is top of stack
3 ds-reg 0 LWZ
ds-reg dup cell SUBI ;
M: ppc %unbox ( n reg-class func -- )
! Value must be in r3
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
M: ppc %unbox-long-long ( n func -- )
! Value must be in r3:r4
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
[
3 1 pick local@ STW
4 1 rot cell + local@ STW
] when* ;
M: ppc %unbox-large-struct ( n c-type -- )
! Value must be in r3
! Compute destination address and load struct size
[ 4 1 rot local@ ADDI ] [ heap-size 5 LI ] bi*
! Call the function
"to_value_struct" f %alien-invoke ;
M: ppc %box ( n reg-class func -- )
! If the source is a stack location, load it into freg #0.
! If the source is f, then we assume the value is already in
! freg #0.
>r
over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
r> f %alien-invoke ;
M: ppc %box-long-long ( n func -- )
>r [
3 1 pick local@ LWZ
4 1 rot cell + local@ LWZ
] when* r> f %alien-invoke ;
: struct-return@ ( n -- n )
[ stack-frame get params>> ] unless* local@ ;
M: ppc %prepare-box-struct ( -- )
#! Compute target address for value struct return
3 1 f struct-return@ ADDI
3 1 0 local@ STW ;
M: ppc %box-large-struct ( n c-type -- )
! If n = f, then we're boxing a returned struct
! Compute destination address and load struct size
[ 3 1 rot struct-return@ ADDI ] [ heap-size 4 LI ] bi*
! Call the function
"box_value_struct" f %alien-invoke ;
M: ppc %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
"stack_chain" f 11 %load-dlsym
11 11 0 LWZ
1 11 0 STW
ds-reg 11 8 STW
rs-reg 11 12 STW ;
M: ppc %alien-invoke ( symbol dll -- )
11 %load-dlsym 11 MTLR BLRL ;
M: ppc %alien-callback ( quot -- )
3 load-indirect "c_to_factor" f %alien-invoke ;
M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
13 3 MR ;
M: ppc %alien-indirect ( -- )
13 MTLR BLRL ;
M: ppc %callback-value ( ctype -- )
! Save top of data stack
3 ds-reg 0 LWZ
3 1 0 local@ STW
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
! Restore top of data stack
3 1 0 local@ LWZ
! Unbox former top of data stack to return registers
unbox-return ;
M: ppc value-structs?
#! On Linux/PPC, value structs are passed in the same way
#! as reference structs, we just have to make a copy first.
os linux? not ;
M: ppc fp-shadows-int? ( -- ? ) os macosx? ;
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
M: ppc struct-small-enough? ( size -- ? ) drop f ;
M: ppc %box-small-struct
drop "No small structs" throw ;
M: ppc %unbox-small-struct
drop "No small structs" throw ;

2
basis/cpu/x86/32/32.factor
View File

@ -3,7 +3,7 @@
USING: locals alien.c-types alien.syntax arrays kernel
math namespaces sequences system layouts io vocabs.loader
accessors init combinators command-line cpu.x86.assembler
cpu.x86.architecture cpu.architecture compiler compiler.units
cpu.x86 cpu.architecture compiler compiler.units
compiler.constants compiler.alien compiler.codegen
compiler.codegen.fixup compiler.cfg.instructions
compiler.cfg.builder compiler.cfg.intrinsics ;

2
basis/cpu/x86/64/64.factor
View File

@ -3,7 +3,7 @@
USING: accessors arrays kernel math namespaces make sequences
system layouts alien alien.c-types alien.accessors alien.structs
slots splitting assocs combinators cpu.x86.assembler
cpu.x86.architecture cpu.architecture compiler.constants
cpu.x86 cpu.architecture compiler.constants
compiler.codegen compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
compiler.cfg.intrinsics ;

1
basis/cpu/x86/architecture/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

1
basis/cpu/x86/architecture/tags.txt
View File

@ -1 +0,0 @@
unportable

10
basis/cpu/x86/bootstrap.factor
View File

@ -271,9 +271,7 @@ big-endian off
: jit-math ( insn -- )
arg0 ds-reg [] MOV ! load second input
ds-reg bootstrap-cell SUB ! pop stack
arg1 ds-reg [] MOV ! load first input
[ arg1 arg0 ] dip execute ! compute result
ds-reg [] arg1 MOV ! push result
[ ds-reg [] arg0 ] dip execute ! compute result
;
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
@ -296,10 +294,8 @@ big-endian off
[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
[
arg0 ds-reg [] MOV ! load input input
arg0 NOT ! complement
arg0 tag-mask get XOR ! clear tag bits
ds-reg [] arg0 MOV ! save
ds-reg [] NOT ! complement
ds-reg [] tag-mask get XOR ! clear tag bits
] f f f \ fixnum-bitnot define-sub-primitive
[

84
basis/cpu/x86/architecture/architecture.factor → basis/cpu/x86/x86.factor
View File

@ -7,7 +7,7 @@ words system layouts combinators math.order fry locals
compiler.constants compiler.cfg.registers
compiler.cfg.instructions compiler.codegen
compiler.codegen.fixup ;
IN: cpu.x86.architecture
IN: cpu.x86
M: x86 two-operand? t ;
@ -111,49 +111,54 @@ M:: x86 %integer>bignum ( dst src temp -- )
#! 1 cell header, 1 cell length, 1 cell sign, + digits
#! length is the # of digits + sign
[
{ "end" "nonzero" "positive" } [ define-label ] each
src 0 CMP ! is it zero?
"nonzero" get JNE
! Use cached zero value
"end" define-label
! Load cached zero value
dst 0 >bignum %load-indirect
"end" get JMP
"nonzero" resolve-label
src 0 CMP
! Is it zero? Then just go to the end and return this zero
"end" get JE
! Allocate a bignum
dst 4 cells bignum temp %allot
! Write length
dst 1 bignum@ 2 tag-fixnum MOV
! Test sign
src 0 CMP
"positive" get JGE
dst 2 bignum@ 1 MOV ! negative sign
src NEG
dst 3 bignum@ src MOV
src NEG ! we don't want to clobber src
"end" get JMP
"positive" resolve-label
dst 2 bignum@ 0 MOV ! positive sign
! Store value
dst 3 bignum@ src MOV
! Compute sign
temp src MOV
temp cell-bits 1- SAR
temp 1 AND
! Store sign
dst 2 bignum@ temp MOV
! Make negative value positive
temp temp ADD
temp NEG
temp 1 ADD
src temp IMUL2
! Store the bignum
dst 3 bignum@ temp MOV
"end" resolve-label
] with-scope ;
M:: x86 %bignum>integer ( dst src -- )
M:: x86 %bignum>integer ( dst src temp -- )
[
"nonzero" define-label
"end" define-label
dst src 1 bignum@ MOV
! if the length is 1, its just the sign and nothing else,
! so output 0
dst 1 tag-fixnum CMP
"nonzero" get JNE
! load length
temp src 1 bignum@ MOV
! if the length is 1, its just the sign and nothing else,
! so output 0
dst 0 MOV
"end" get JMP
"nonzero" resolve-label
temp 1 tag-fixnum CMP
"end" get JE
! load the value
dst src 3 bignum@ MOV
! is the sign negative?
src 2 bignum@ 0 CMP
"end" get JE
dst NEG
! load the sign
temp src 2 bignum@ MOV
! convert it into -1 or 1
temp temp ADD
temp NEG
temp 1 ADD
! make dst signed
temp dst IMUL2
"end" resolve-label
] with-scope ;
@ -206,21 +211,19 @@ M:: x86 %box-float ( dst src temp -- )
dst 16 float temp %allot
dst float-offset [+] src MOVSD ;
: alien@ ( reg n -- op ) cells object tag-number - [+] ;
: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
M:: x86 %box-alien ( dst src temp -- )
[
{ "end" "f" } [ define-label ] each
"end" define-label
dst \ f tag-number MOV
src 0 CMP
"f" get JE
"end" get JE
dst 4 cells alien temp %allot
dst 1 alien@ \ f tag-number MOV
dst 2 alien@ \ f tag-number MOV
! Store src in alien-offset slot
dst 3 alien@ src MOV
"end" get JMP
"f" resolve-label
dst \ f tag-number MOV
"end" resolve-label
] with-scope ;
@ -339,7 +342,7 @@ M: x86 %set-alien-double [ [] ] dip MOVSD ;
: inc-allot-ptr ( nursery-ptr n -- )
[ cell [+] ] dip 8 align ADD ;
: store-header ( temp type -- )
: store-header ( temp class -- )
[ [] ] [ type-number tag-fixnum ] bi* MOV ;
: store-tagged ( dst tag -- )
@ -463,11 +466,10 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ;
M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ;
M: x86 %spill-float spill-float@ swap MOVSD ;
M: x86 %reload-float spill-float@ MOVSD ;
M: x86 %spill-float ( src n -- ) spill-float@ swap MOVSD ;
M: x86 %reload-float ( dst n -- ) spill-float@ MOVSD ;
M: x86 %loop-entry
16 code-alignment [ NOP ] times ;
M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
M: int-regs %save-param-reg drop >r stack@ r> MOV ;
M: int-regs %load-param-reg drop swap stack@ MOV ;

2
basis/help/help-docs.factor
View File

@ -407,7 +407,7 @@ HELP: ARTICLE:
} ;
HELP: ABOUT:
{ $syntax "MAIN: article" }
{ $syntax "ABOUT: article" }
{ $values { "article" "a help article" } }
{ $description "Defines the main documentation article for the current vocabulary." } ;

9
basis/locals/locals-tests.factor
View File

@ -1,7 +1,8 @@
USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit
combinators.short-circuit.smart math.order math.functions ;
combinators.short-circuit.smart math.order math.functions
definitions compiler.units ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
@ -378,6 +379,12 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
[ 9 ] [ 3 big-case-test ] unit-test
GENERIC: lambda-method-forget-test ( a -- b )
M:: integer lambda-method-forget-test ( a -- b ) ;
[ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test
! :: wlet-&&-test ( a -- ? )
! [wlet | is-integer? [ a integer? ]
! is-even? [ a even? ]

2
basis/locals/locals.factor
View File

@ -450,7 +450,7 @@ M: lambda-method definition
"lambda" word-prop body>> ;
M: lambda-method reset-word
[ f "lambda" set-word-prop ] [ call-next-method ] bi ;
[ call-next-method ] [ f "lambda" set-word-prop ] bi ;
INTERSECTION: lambda-memoized memoized lambda-word ;

14
basis/prettyprint/prettyprint.factor
View File

@ -134,6 +134,20 @@ PRIVATE>
: pprint-cell ( obj -- ) [ pprint ] with-cell ;
: simple-table. ( values -- )
standard-table-style [
[
[
[
dup string?
[ [ write ] with-cell ]
[ pprint-cell ]
if
] each
] with-row
] each
] tabular-output ;
GENERIC: see ( defspec -- )
: comment. ( string -- )

14
basis/tools/time/time.factor
View File

@ -7,20 +7,6 @@ IN: tools.time
: benchmark ( quot -- runtime )
millis >r call millis r> - ; inline
: simple-table. ( values -- )
standard-table-style [
[
[
[
dup string?
[ [ write ] with-cell ]
[ pprint-cell ]
if
] each
] with-row
] each
] tabular-output ;
: time. ( data -- )
unclip
"==== RUNNING TIME" print nl pprint " ms" print nl

2
basis/ui/tools/tools-docs.factor
View File

@ -117,7 +117,7 @@ ARTICLE: "ui-workspace-keys" "UI keyboard shortcuts"
{ $heading "Implementation" }
"Workspaces are instances of " { $link workspace } "." ;
ARTICLE: "ui-tools" "UI development tools"
ARTICLE: "ui-tools" "UI developer tools"
"The Factor development environment can seem rather different from what you are used to, because it is very simple and powerful.."
$nl
"To take full advantage of the UI, you should be using a supported text editor. See " { $link "editor" } "."

23
basis/unix/groups/groups-docs.factor
View File

@ -4,21 +4,15 @@ USING: help.markup help.syntax io.streams.string kernel quotations sequences str
IN: unix.groups
HELP: all-groups
{ $values
{ "seq" sequence } }
{ $values { "seq" sequence } }
{ $description "Returns a sequence of " { $link group } " tuples that are platform-dependent and field for field complete with the Unix " { $link group } " structure." } ;
HELP: effective-group-id
{ $values
{ "string" string } }
{ $values { "string" string } }
{ $description "Returns the effective group id for the current user." } ;
HELP: effective-group-name
{ $values
{ "string" string } }
{ $values { "string" string } }
{ $description "Returns the effective group name for the current user." } ;
HELP: group
@ -46,15 +40,11 @@ HELP: group-struct
{ $description "Returns an alien group struct to be turned into a group tuple by calling subsequent words." } ;
HELP: real-group-id
{ $values
{ "id" integer } }
{ $values { "id" integer } }
{ $description "Returns the real group id for the current user." } ;
HELP: real-group-name
{ $values
{ "string" string } }
{ $values { "string" string } }
{ $description "Returns the real group name for the current user." } ;
HELP: set-effective-group
@ -88,8 +78,9 @@ HELP: with-real-group
{ "string/id" "a string or a group id" } { "quot" quotation } }
{ $description "Sets the real group name and calls the quotation. Restores the current group name on success or on error after the call." } ;
ARTICLE: "unix.groups" "unix.groups"
ARTICLE: "unix.groups" "Unix groups"
"The " { $vocab-link "unix.groups" } " vocabulary contains words that return information about Unix groups."
$nl
"Listing all groups:"
{ $subsection all-groups }
"Returning a passwd tuple:"

33
basis/unix/users/users-docs.factor
View File

@ -4,27 +4,19 @@ USING: help.markup help.syntax io.streams.string kernel quotations sequences str
IN: unix.users
HELP: all-users
{ $values
{ "seq" sequence } }
{ $values { "seq" sequence } }
{ $description "Returns a sequence of high-level " { $link passwd } " tuples that are platform-dependent and field for field complete with the Unix " { $link passwd } " structure." } ;
HELP: effective-username
{ $values
{ "string" string } }
{ $values { "string" string } }
{ $description "Returns the effective username for the current user." } ;
HELP: effective-user-id
{ $values
{ "id" integer } }
{ $values { "id" integer } }
{ $description "Returns the effective username id for the current user." } ;
HELP: new-passwd
{ $values
{ "passwd" passwd } }
{ $values { "passwd" passwd } }
{ $description "Creates a new passwd tuple dependent on the operating system." } ;
HELP: passwd
@ -40,25 +32,19 @@ HELP: passwd>new-passwd
{ $description "A platform-specific conversion routine from a passwd structure to a passwd tuple." } ;
HELP: real-username
{ $values
{ "string" string } }
{ $values { "string" string } }
{ $description "The real username of the current user." } ;
HELP: real-user-id
{ $values
{ "id" integer } }
{ $values { "id" integer } }
{ $description "The real user id of the current user." } ;
HELP: set-effective-user
{ $values
{ "string/id" "a string or a user id" } }
{ $values { "string/id" "a string or a user id" } }
{ $description "Sets the current effective user given a username or a user id." } ;
HELP: set-real-user
{ $values
{ "string/id" "a string or a user id" } }
{ $values { "string/id" "a string or a user id" } }
{ $description "Sets the current real user given a username or a user id." } ;
HELP: user-passwd
@ -100,8 +86,9 @@ HELP: with-real-user
set-effective-user
} related-words
ARTICLE: "unix.users" "unix.users"
ARTICLE: "unix.users" "Unix users"
"The " { $vocab-link "unix.users" } " vocabulary contains words that return information about Unix users."
$nl
"Listing all users:"
{ $subsection all-users }
"Returning a passwd tuple:"

8
core/classes/algebra/algebra.factor
View File

@ -20,6 +20,14 @@ C: <anonymous-complement> anonymous-complement
: 2cache ( key1 key2 assoc quot -- value )
>r >r 2array r> [ first2 ] r> compose cache ; inline
GENERIC: valid-class? ( obj -- ? )
M: class valid-class? drop t ;
M: anonymous-union valid-class? members>> [ valid-class? ] all? ;
M: anonymous-intersection valid-class? participants>> [ valid-class? ] all? ;
M: anonymous-complement valid-class? class>> valid-class? ;
M: word valid-class? drop f ;
DEFER: (class<=)
: class<= ( first second -- ? )

34
core/classes/classes-tests.factor
View File

@ -79,3 +79,37 @@ USE: multiline
: q ( -- b ) j new g ;"> <string-reader>
"class-intersect-no-method-b" parse-stream drop
] unit-test
! Similar problem, but with anonymous classes
[ ] [
<" IN: classes.test.c
USE: kernel
GENERIC: g ( a -- b )
M: object g ;
TUPLE: z ;"> <string-reader>
"class-intersect-no-method-c" parse-stream drop
] unit-test
[ ] [
<" IN: classes.test.d
USE: classes.test.c
USE: kernel
: q ( a -- b ) dup z? [ g ] unless ;"> <string-reader>
"class-intersect-no-method-d" parse-stream drop
] unit-test
! Now, the user removes the z class and adds a method,
[ ] [
<" IN: classes.test.c
USE: kernel
GENERIC: g ( a -- b )
M: object g ;
TUPLE: j ;
M: j g ;"> <string-reader>
"class-intersect-no-method-c" parse-stream drop
] unit-test
TUPLE: forgotten-predicate-test ;
[ ] [ [ \ forgotten-predicate-test forget ] with-compilation-unit ] unit-test
[ f ] [ \ forgotten-predicate-test? predicate? ] unit-test

24
core/classes/classes.factor
View File

@ -32,8 +32,7 @@ SYMBOL: update-map
SYMBOL: implementors-map
PREDICATE: class < word
"class" word-prop ;
PREDICATE: class < word "class" word-prop ;
: classes ( -- seq ) implementors-map get keys ;
@ -42,9 +41,12 @@ PREDICATE: class < word
PREDICATE: predicate < word "predicating" word-prop >boolean ;
M: predicate reset-word
[ call-next-method ] [ { "predicating" } reset-props ] bi ;
: define-predicate ( class quot -- )
>r "predicate" word-prop first
r> (( object -- ? )) define-declared ;
[ "predicate" word-prop first ] dip
(( object -- ? )) define-declared ;
: superclass ( class -- super )
#! Output f for non-classes to work with algebra code
@ -121,13 +123,13 @@ M: sequence implementors [ implementors ] gather ;
] H{ } make-assoc ;
: (define-class) ( word props -- )
>r
dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
dup reset-class
dup deferred? [ dup define-symbol ] when
dup redefined
dup props>>
r> assoc-union >>props
[
dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
dup reset-class
dup deferred? [ dup define-symbol ] when
dup redefined
dup props>>
] dip assoc-union >>props
dup predicate-word
[ 1quotation "predicate" set-word-prop ]
[ swap "predicating" set-word-prop ]

2
core/compiler/units/units.factor
View File

@ -111,7 +111,7 @@ SYMBOL: remake-generics-hook
: (compiled-generic-usages) ( generic class -- assoc )
[ compiled-generic-usage ] dip
[
2dup [ class? ] both?
2dup [ valid-class? ] both?
[ classes-intersect? ] [ 2drop f ] if nip
] curry assoc-filter ;

12
core/words/words.factor
View File

@ -204,13 +204,9 @@ GENERIC: reset-word ( word -- )
M: word reset-word
{
"unannotated-def"
"parsing" "inline" "recursive" "foldable" "flushable"
"predicating"
"reading" "writing"
"reader" "writer"
"constructing"
"declared-effect" "constructor-quot" "delimiter"
"unannotated-def" "parsing" "inline" "recursive"
"foldable" "flushable" "reading" "writing" "reader"
"writer" "declared-effect" "delimiter"
} reset-props ;
GENERIC: subwords ( word -- seq )
@ -261,7 +257,7 @@ M: word forget*
dup "forgotten" word-prop [ drop ] [
[ delete-xref ]
[ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ]
[ t "forgotten" set-word-prop ]
[ [ reset-word ] [ t "forgotten" set-word-prop ] bi ]
tri
] if ;

12
extra/mason/platform/platform.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel system accessors namespaces splitting sequences make
USING: kernel system accessors namespaces splitting sequences
mason.config ;
IN: mason.platform
@ -10,10 +10,8 @@ IN: mason.platform
: gnu-make ( -- string )
target-os get { "freebsd" "openbsd" "netbsd" } member? "gmake" "make" ? ;
: boot-image-arch ( -- string )
target-cpu get dup "ppc" = [ target-os get "-" append prepend ] when ;
: boot-image-name ( -- string )
[
"boot." %
target-cpu get "ppc" = [ target-os get % "-" % ] when
target-cpu get %
".image" %
] "" make ;
"boot." boot-image-arch ".image" 3append ;

3
extra/mason/updates/updates.factor
View File

@ -20,7 +20,8 @@ IN: mason.updates
= not ;
: new-image-available? ( -- ? )
boot-image-name need-new-image? [ download-my-image t ] [ f ] if ;
boot-image-name need-new-image?
[ boot-image-arch download-image t ] [ f ] if ;
: new-code-available? ( -- ? )
updates-available?

233
vm/cpu-ppc.S
View File

@ -4,30 +4,32 @@ in the public domain. */
/* Note that the XT is passed to the quotation in r11 */
#define CALL_OR_JUMP_QUOT \
lwz r11,9(r3) /* load quotation-xt slot */ XX \
lwz r11,9(r3) /* load quotation-xt slot */ XX \
#define CALL_QUOT \
CALL_OR_JUMP_QUOT XX \
mtlr r11 /* prepare to call XT with quotation in r3 */ XX \
blrl /* go */
CALL_OR_JUMP_QUOT XX \
mtlr r11 /* prepare to call XT with quotation in r3 */ XX \
blrl /* go */
#define JUMP_QUOT \
CALL_OR_JUMP_QUOT XX \
mtctr r11 /* prepare to call XT with quotation in r3 */ XX \
bctr /* go */
CALL_OR_JUMP_QUOT XX \
mtctr r11 /* prepare to call XT with quotation in r3 */ XX \
bctr /* go */
#define PARAM_SIZE 32
#define SAVED_REGS_SIZE 96
#define SAVED_INT_REGS_SIZE 96
#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_REGS_SIZE + 8)
#define SAVED_FP_REGS_SIZE 144
#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_INT_REGS_SIZE + SAVED_FP_REGS_SIZE + 8)
#if defined( __APPLE__)
#define LR_SAVE 8
#define RESERVED_SIZE 24
#define LR_SAVE 8
#define RESERVED_SIZE 24
#else
#define LR_SAVE 4
#define RESERVED_SIZE 8
#define LR_SAVE 4
#define RESERVED_SIZE 8
#endif
#define SAVE_LR(reg) stw reg,(LR_SAVE + FRAME)(r1)
@ -36,99 +38,142 @@ in the public domain. */
#define SAVE_AT(offset) (RESERVED_SIZE + PARAM_SIZE + 4 * offset)
#define SAVE(register,offset) stw register,SAVE_AT(offset)(r1)
#define SAVE_INT(register,offset) stw register,SAVE_AT(offset)(r1)
#define RESTORE_INT(register,offset) lwz register,SAVE_AT(offset)(r1)
#define RESTORE(register,offset) lwz register,SAVE_AT(offset)(r1)
#define SAVE_FP(register,offset) stfd register,SAVE_AT(offset)(r1)
#define RESTORE_FP(register,offset) lfd register,SAVE_AT(offset)(r1)
#define PROLOGUE \
mflr r0 XX /* get caller's return address */ \
stwu r1,-FRAME(r1) XX /* create a stack frame to hold non-volatile registers */ \
SAVE_LR(r0)
mflr r0 XX /* get caller's return address */ \
stwu r1,-FRAME(r1) XX /* create a stack frame to hold non-volatile registers */ \
SAVE_LR(r0)
#define EPILOGUE \
LOAD_LR(r0) XX \
lwz r1,0(r1) XX /* destroy the stack frame */ \
mtlr r0 /* get ready to return */
lwz r1,0(r1) XX /* destroy the stack frame */ \
mtlr r0 /* get ready to return */
/* We have to save and restore nonvolatile registers because
the Factor compiler treats the entire register file as volatile. */
DEF(void,c_to_factor,(CELL quot)):
PROLOGUE
PROLOGUE
SAVE(r13,0) /* save GPRs */
/* don't save ds pointer */
/* don't save rs pointer */
SAVE(r16,3)
SAVE(r17,4)
SAVE(r18,5)
SAVE(r19,6)
SAVE(r20,7)
SAVE(r21,8)
SAVE(r22,9)
SAVE(r23,10)
SAVE(r24,11)
SAVE(r25,12)
SAVE(r26,13)
SAVE(r27,14)
SAVE(r28,15)
SAVE(r29,16)
SAVE(r30,17)
SAVE(r31,18)
SAVE(r3,19) /* save quotation since we're about to mangle it */
SAVE_INT(r13,0) /* save GPRs */
/* don't save ds pointer */
/* don't save rs pointer */
SAVE_INT(r16,3)
SAVE_INT(r17,4)
SAVE_INT(r18,5)
SAVE_INT(r19,6)
SAVE_INT(r20,7)
SAVE_INT(r21,8)
SAVE_INT(r22,9)
SAVE_INT(r23,10)
SAVE_INT(r24,11)
SAVE_INT(r25,12)
SAVE_INT(r26,13)
SAVE_INT(r27,14)
SAVE_INT(r28,15)
SAVE_INT(r29,16)
SAVE_INT(r30,17)
SAVE_INT(r31,18)
mr r3,r1 /* pass call stack pointer as an argument */
SAVE_FP(f14,20) /* save FPRs */
SAVE_FP(f15,22)
SAVE_FP(f16,24)
SAVE_FP(f17,26)
SAVE_FP(f18,28)
SAVE_FP(f19,30)
SAVE_FP(f20,32)
SAVE_FP(f21,34)
SAVE_FP(f22,36)
SAVE_FP(f23,38)
SAVE_FP(f24,40)
SAVE_FP(f25,42)
SAVE_FP(f26,44)
SAVE_FP(f27,46)
SAVE_FP(f28,48)
SAVE_FP(f29,50)
SAVE_FP(f30,52)
SAVE_FP(f31,54)
SAVE_INT(r3,19) /* save quotation since we're about to mangle it */
mr r3,r1 /* pass call stack pointer as an argument */
bl MANGLE(save_callstack_bottom)
RESTORE(r3,19) /* restore quotation */
CALL_QUOT
RESTORE_INT(r3,19) /* restore quotation */
CALL_QUOT
RESTORE(r31,18) /* restore GPRs */
RESTORE(r30,17)
RESTORE(r29,16)
RESTORE(r28,15)
RESTORE(r27,14)
RESTORE(r26,13)
RESTORE(r25,12)
RESTORE(r24,11)
RESTORE(r23,10)
RESTORE(r22,9)
RESTORE(r21,8)
RESTORE(r20,7)
RESTORE(r19,6)
RESTORE(r18,5)
RESTORE(r17,4)
RESTORE(r16,3)
/* don't restore rs pointer */
/* don't restore ds pointer */
RESTORE(r13,0)
RESTORE_FP(f31,54)
RESTORE_FP(f30,52)
RESTORE_FP(f29,50)
RESTORE_FP(f28,48)
RESTORE_FP(f27,46)
RESTORE_FP(f26,44)
RESTORE_FP(f25,42)
RESTORE_FP(f24,40)
RESTORE_FP(f23,38)
RESTORE_FP(f22,36)
RESTORE_FP(f21,34)
RESTORE_FP(f20,32)
RESTORE_FP(f19,30)
RESTORE_FP(f18,28)
RESTORE_FP(f17,26)
RESTORE_FP(f16,24)
RESTORE_FP(f15,22)
RESTORE_FP(f14,20) /* save FPRs */
EPILOGUE
blr
RESTORE_INT(r31,18) /* restore GPRs */
RESTORE_INT(r30,17)
RESTORE_INT(r29,16)
RESTORE_INT(r28,15)
RESTORE_INT(r27,14)
RESTORE_INT(r26,13)
RESTORE_INT(r25,12)
RESTORE_INT(r24,11)
RESTORE_INT(r23,10)
RESTORE_INT(r22,9)
RESTORE_INT(r21,8)
RESTORE_INT(r20,7)
RESTORE_INT(r19,6)
RESTORE_INT(r18,5)
RESTORE_INT(r17,4)
RESTORE_INT(r16,3)
/* don't restore rs pointer */
/* don't restore ds pointer */
RESTORE_INT(r13,0)
EPILOGUE
blr
/* We pass a function pointer to memcpy in r6 to work around a Mac OS X ABI
limitation which would otherwise require us to do a bizzaro PC-relative
trampoline to retrieve the function address */
DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)):
sub r1,r3,r5 /* compute new stack pointer */
mr r3,r1 /* start of destination of memcpy() */
stwu r1,-64(r1) /* setup fake stack frame for memcpy() */
mtlr r6 /* prepare to call memcpy() */
blrl /* go */
lwz r1,0(r1) /* tear down fake stack frame */
lwz r0,LR_SAVE(r1) /* we have restored the stack; load return address */
mtlr r0 /* prepare to return to restored callstack */
blr /* go */
sub r1,r3,r5 /* compute new stack pointer */
mr r3,r1 /* start of destination of memcpy() */
stwu r1,-64(r1) /* setup fake stack frame for memcpy() */
mtlr r6 /* prepare to call memcpy() */
blrl /* go */
lwz r1,0(r1) /* tear down fake stack frame */
lwz r0,LR_SAVE(r1) /* we have restored the stack; load return address */
mtlr r0 /* prepare to return to restored callstack */
blr /* go */
DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
mr r1,r4 /* compute new stack pointer */
mr r1,r4 /* compute new stack pointer */
lwz r0,LR_SAVE(r1) /* we have rewound the stack; load return address */
mtlr r0
JUMP_QUOT /* call the quotation */
JUMP_QUOT /* call the quotation */
DEF(void,lazy_jit_compile,(CELL quot)):
mr r4,r1 /* save stack pointer */
mr r4,r1 /* save stack pointer */
PROLOGUE
bl MANGLE(primitive_jit_compile)
EPILOGUE
JUMP_QUOT /* call the quotation */
JUMP_QUOT /* call the quotation */
/* Thanks to Joshua Grams for this code.
@ -136,19 +181,19 @@ On PowerPC processors, we must flush the instruction cache manually
after writing to the code heap. */
DEF(void,flush_icache,(void *start, int len)):
/* compute number of cache lines to flush */
add r4,r4,r3
clrrwi r3,r3,5 /* align addr to next lower cache line boundary */
sub r4,r4,r3 /* then n_lines = (len + 0x1f) / 0x20 */
addi r4,r4,0x1f
srwi. r4,r4,5 /* note '.' suffix */
beqlr /* if n_lines == 0, just return. */
mtctr r4 /* flush cache lines */
0: dcbf 0,r3 /* for each line... */
sync
icbi 0,r3
addi r3,r3,0x20
bdnz 0b
sync /* finish up */
isync
blr
/* compute number of cache lines to flush */
add r4,r4,r3
clrrwi r3,r3,5 /* align addr to next lower cache line boundary */
sub r4,r4,r3 /* then n_lines = (len + 0x1f) / 0x20 */
addi r4,r4,0x1f
srwi. r4,r4,5 /* note '.' suffix */
beqlr /* if n_lines == 0, just return. */
mtctr r4 /* flush cache lines */
0: dcbf 0,r3 /* for each line... */
sync
icbi 0,r3
addi r3,r3,0x20
bdnz 0b
sync /* finish up */
isync
blr

4
vm/cpu-ppc.h
View File

@ -1,8 +1,8 @@
#define FACTOR_CPU_STRING "ppc"
#define F_FASTCALL
register CELL ds asm("r14");
register CELL rs asm("r15");
register CELL ds asm("r30");
register CELL rs asm("r31");
void c_to_factor(CELL quot);
void undefined(CELL word);